trying to use semaphores

.github/workflows/build.yml

@@ -11,51 +11,35 @@ on:
 
 jobs:
   build:
-    name: build-${{ matrix.os }}
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        include:
-          - os: ubuntu-18.04
-          - os: ubuntu-20.04
+    runs-on: ubuntu-20.04
     steps:
       - name: Clone project
         uses: actions/checkout@v2
 
-      - name: Setup Haskell
+      - name: Setup Stack
         uses: haskell/actions/setup@v1
         with:
           ghc-version: "8.10.7"
-          cabal-version: "latest"
+          enable-stack: true
+          stack-version: "latest"
 
       - name: Cache dependencies
         uses: actions/cache@v2
         with:
-          path: |
-            ~/.cabal/store
-            dist-newstyle
-          key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
+          path: ~/.stack
+          key: ${{ hashFiles('stack.yaml') }}
 
-      - name: Build
-        shell: bash
-        run: cabal build --enable-tests
-
-      - name: Test
-        if: matrix.os == 'ubuntu-18.04'
-        timeout-minutes: 30
-        shell: bash
-        run: cabal test --test-show-details=direct
-
-      - name: Prepare binaries
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+      - name: Build & test
+        id: build_test
         shell: bash
         run: |
-          mv $(cabal list-bin smp-server) smp-server-ubuntu-20_04-x86-64
-          mv $(cabal list-bin ntf-server) ntf-server-ubuntu-20_04-x86-64
+          stack build --test --force-dirty
+          install_root=$(stack path --local-install-root)
+          mv ${install_root}/bin/smp-server smp-server-ubuntu-20_04-x86-64
+          mv ${install_root}/bin/ntf-server ntf-server-ubuntu-20_04-x86-64
 
       - name: Build changelog
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+        if: startsWith(github.ref, 'refs/tags/v')
         id: build_changelog
         uses: mikepenz/release-changelog-builder-action@v1
         with:
@@ -66,8 +50,19 @@ jobs:
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
+      - name: Extract release candidate
+        if: startsWith(github.ref, 'refs/tags/v')
+        id: extract_release_candidate
+        shell: bash
+        run: |
+          if [[ ${GITHUB_REF} == *rc* ]]; then
+            echo "::set-output name=release_candidate::true"
+          else
+            echo "::set-output name=release_candidate::false"
+          fi
+
       - name: Create release
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+        if: startsWith(github.ref, 'refs/tags/v')
         uses: softprops/action-gh-release@v1
         with:
           body: |
@@ -75,7 +70,7 @@ jobs:
 
             Commits:
             ${{ steps.build_changelog.outputs.changelog }}
-          prerelease: true
+          prerelease: ${{ steps.extract_release_candidate.outputs.release_candidate }}
           files: |
             LICENSE
             smp-server-ubuntu-20_04-x86-64

.gitignore

@@ -4,6 +4,3 @@
 *.session.sql
 tests/tmp
 dist-newstyle/
-
-cabal.project.local
-cabal.project.local~

CHANGELOG.md

@@ -1,130 +1,3 @@
-# 4.3.0
-
-SMP server:
-
-- additional server usage statistics.
-
-SMP agent:
-
-- increase retry interval when sending messages after ERR QUOTA.
-
-# 4.2.0
-
-SMP agent and server:
-
-- reduce sender traffic in cases when queue quota is exceeded:
-  - server sends quota exceeded message to the recipient when sender receives ERR QUOTA.
-  - recipient sends QCONT message to the send once the queue is drained (via reply queue).
-  - sender retry delays are increased, reducing traffic, but sender instantly resumes delivery where QCONT is received.
-
-SMP server:
-
-- increase internal queue sizes.
-
-SMP agent:
-
-- deduplicate connection IDs in connect/disconnect responses.
-- unit tests for Crypto.hs.
-- fix connection switch to another queue: correctly set primary send queue.
-
-Notification server (v1.3.0):
-
-- check token status when sending verification notificaiton.
-
-# 4.1.0
-
-SMP agent and server:
-
-- option to toggle TLS handshake error logs (disabled by default).
-
-SMP agent:
-
-- include server address in BROKER error.
-- api to get hash of double ratchet associated data (for connection verification).
-- api to get agent statistics.
-
-# 4.0.0
-
-SMP server:
-
-- Basic authentication. The server address can now include an optional password that is required to create messaging queues, so the contacts who message you will not be able to receive messages via your server, unless you share with them the address with the password. It is recommended to enable basic authentication on all private servers by adding `create_password` parameter into AUTH section of server INI file (the previously deployed servers do not have this section, you need to add it).
-- Disable creating new queues completely with `new_queues: off` parameter in AUTH section of INI file - it can be used to simplify migrating the exising connections to another server.
-- Updated server CLI with changed defaults:
-  - interactive server initialization, use -y flag to initalize the server non-interactively.
-  - store log is now enabled by default, so messaging queues and messages are restored when the server is restarted (to restore undelivered messages the server needs to be stopped with SIGINT signal).
-  - a random password is now generated by default during the server initialization.
-
-SMP agent:
-
-- API to test SMP servers. It connects to the server, creates and deletes a messaging queue. The new SimpleX Chat client uses this API to allow you to test that you have the correct server address, with the valid certificate fingerprint and pasword, before enabling the new server.
-
-# 3.4.0
-
-SMP agent:
-
-- increase concurrency with connection-level locks
-- fix issues identified in security assessment (see the announcement: https://github.com/simplex-chat/simplex-chat/blob/stable/blog/20221108-simplex-chat-v4.2-security-audit-new-website.md)
-- manual connection queue rotation
-- optional client data in connection requests links
-
-SMP server:
-
-- specialize monad stack to improve performance
-- log slow commands
-
-# 3.3.0
-
-SMP server:
-
-- allow repeated KEY command with the same key (to avoid failures on retries)
-
-SMP agent:
-
-- enable/disable connection notifications
-- asynchronous commands that retry on network error
-- use SQLCipher
-
-# 3.2.0
-
-SMP agent:
-
-- Support multiple server hostnames (including onion hostnames) in server addresses.
-- Network configuration options.
-- Options to define rules to choose server hostname.
-
-# 3.1.0
-
-SMP server and agent:
-
-- SMP protocol v4: batching multiple server commands/responses in a transport block.
-
-# 3.0.0
-
-SMP server:
-
-- restore undeliverd messages when the server is restarted.
-- SMP protocol v3 to support push notification:
-  - updated SEND and MSG to add message flags (for notification flag that contros whether the notification is sent and for any future extensions) and to move message meta-data sent to the recipient into the encrypted envelope.
-  - update NKEY and NID to add e2e encryption keys (for the notification meta-data encryption between SMP server and the client), and update NMSG to include this meta-data.
-  - update ACK command to include message ID (to avoid acknowledging unprocessed message).
-  - add NDEL commands to remove notification subscription credentials from SMP queue.
-  - add GET command to receive messages without subscription - to be used in iOS notification service extension to receive messages without terminating app subscriptions.
-
-SMP agent:
-
-- new protocol for duplex connection handshake reducing traffic and connection time.
-- support for SMP notifications server and managing device token.
-- remove redundant FQDN validation from TLS handshake to prepare for access via Tor.
-- support for fully stopping agent and for termporary suspending agent operations.
-- improve management of duplicate message delivery.
-
-SMP notifications server v1.0:
-
-- SMP notifications protocol with version negotiation during handshake.
-- device token registration and verification (via background notification).
-- SMP notification subscriptions and push notifications via APNS.
-- restoring notification subscriptions when the server is restarted.
-
 # 2.3.0
 
 SMP server:

README.md

@@ -11,7 +11,7 @@ If you have a server deployed please deploy a new server to a new host and retir
 
 ## Message broker for unidirectional (simplex) queues
 
-SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
+SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
 
 SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
 
@@ -27,7 +27,7 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
 
 ### SMP server
 
-[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
+[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
 
 To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
 
@@ -39,7 +39,7 @@ Starting from version 2.3.0, when store log is enabled, the server would also en
 
 > **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
 
-SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
+SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
 
 #### Running SMP server on MacOS
 
@@ -62,7 +62,7 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP client library
 
-[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
+[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
 
 - execute commands with a functional API.
 - receive messages and other notifications via STM queue.
@@ -70,13 +70,13 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP agent
 
-[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
+[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
 
-Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
+Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
 
 See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
 
-[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
+[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
 
 ## Using SMP server and SMP agent
 
@@ -94,107 +94,23 @@ It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.
 
 You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
 
-Notice that `smp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
+- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
 
-```sh
-# For Ubuntu
-apt update && apt install openssl
-```
+  If you're using other Linux distribution and the binary is incompatible with it, you can build from source using [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
 
-### Install binaries
-
-#### Using Docker
-
-On Linux, you can deploy smp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat/simplexmq).
-
-1. Create `config` and `logs` directories:
-
-   ```sh
-   mkdir -p ~/simplex/{config,logs}
-   ```
-
-2. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server:
-   ```sh
-   docker run -d \
-       -e addr="your_ip_or_domain" \
-       -e pass="password" \
-       -p 5223:5223 \
-       -v $HOME/simplex/config:/etc/opt/simplex:z \
-       -v $HOME/simplex/logs:/var/opt/simplex:z \
-       simplexchat/simplexmq
-   ```
-
-#### Ubuntu
-
-For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
-
-### Build from source
-
-#### Using Docker
-
-> **Please note:** to build the app use source code from [stable branch](https://github.com/simplex-chat/simplexmq/tree/stable).
-
-On Linux, you can build smp server using Docker.
-
-1. Build your `smp-server` image:
-
-   ```sh
-   git clone https://github.com/simplex-chat/simplexmq
-   cd simplexmq
-   git checkout stable
-   DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
-   ```
-
-2. Create `config` and `logs` directories:
-
-   ```sh
-   mkdir -p ~/simplex/{config,logs}
-   ```
-
-3. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server::
-   ```sh
-   docker run -d \
-       -e addr="your_ip_or_domain" \
-       -e pass="password" \
-       -p 5223:5223 \
-       -v $HOME/simplex/config:/etc/opt/simplex:z \
-       -v $HOME/simplex/logs:/var/opt/simplex:z \
-       smp-server
-   ```
-
-#### Using your distribution
-
-1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal:
-
-   ```sh
-   curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
-   ghcup install ghc 8.10.7
-   ghcup install cabal
-   ghcup set ghc 8.10.7
-   ghcup set cabal
-   ```
-
-2. Build the project:
-
-   ```sh
-   git clone https://github.com/simplex-chat/simplexmq
-   cd simplexmq
-   git checkout stable
-   # On Ubuntu. Depending on your distribution, use your package manager to determine package names.
-   apt-get update && apt-get install -y build-essential libgmp3-dev zlib1g-dev
-   cabal update
-   cabal install
-   ```
+  ```shell
+  curl -sSL https://get.haskellstack.org/ | sh
+  ...
+  stack install
+  ```
 
 - Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
 
 - Run `smp-server start` to start SMP server, or you can configure a service manager to run it as a service.
 
-- Optionally, `smp-server` can be setup for having an onion address in `tor` network. See: [`scripts/tor`](./scripts/tor/). In this case, the server address can have both public and onion hostname pointing to the same server, to allow two people connect when only one of them is using Tor. The server address would be: `smp://<fingerprint>@<public_hostname>,<onion_hostname>`
-
 See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
 
-[<img alt="Linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
+[<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
 
 ## Deploy SMP server on Linode
 
@@ -218,7 +134,7 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
-[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
+[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
 
 ## Deploy SMP server on DigitalOcean
 
@@ -246,12 +162,12 @@ smp-server init [-l] -n <fqdn>
 
 ## SMP server design
 
-![SMP server design](./design/server.svg)
+![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
 
 ## SMP agent design
 
-![SMP agent design](./design/agent2.svg)
+![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
 
 ## License
 
-[AGPL v3](./LICENSE)
+[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)

apps/ntf-server/Main.hs

@@ -1,7 +1,14 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module Main where
 
 import Control.Logger.Simple
-import Simplex.Messaging.Notifications.Server.Main
+import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import Simplex.Messaging.Notifications.Server (runNtfServer)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
+import System.FilePath (combine)
 
 cfgPath :: FilePath
 cfgPath = "/etc/opt/simplex-notifications"
@@ -15,4 +22,53 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 main :: IO ()
 main = do
   setLogLevel LogDebug -- change to LogError in production
-  withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath
+  withGlobalLogging logCfg $ protocolServerCLI ntfServerCLIConfig runNtfServer
+
+ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig
+ntfServerCLIConfig =
+  let caCrtFile = combine cfgPath "ca.crt"
+      serverKeyFile = combine cfgPath "server.key"
+      serverCrtFile = combine cfgPath "server.crt"
+   in ServerCLIConfig
+        { cfgDir = cfgPath,
+          logDir = logPath,
+          iniFile = combine cfgPath "ntf-server.ini",
+          storeLogFile = combine logPath "ntf-server-store.log",
+          caKeyFile = combine cfgPath "ca.key",
+          caCrtFile,
+          serverKeyFile,
+          serverCrtFile,
+          fingerprintFile = combine cfgPath "fingerprint",
+          defaultServerPort = "443",
+          executableName = "ntf-server",
+          serverVersion = "SMP notifications server v0.1.0",
+          mkIniFile = \enableStoreLog defaultServerPort ->
+            "[STORE_LOG]\n\
+            \# The server uses STM memory for persistence,\n\
+            \# that will be lost on restart (e.g., as with redis).\n\
+            \# This option enables saving memory to append only log,\n\
+            \# and restoring it when the server is started.\n\
+            \# Log is compacted on start (deleted objects are removed).\n\
+            \# The messages are not logged.\n"
+              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+              <> "[TRANSPORT]\n\
+                 \port: "
+              <> defaultServerPort
+              <> "\n\
+                 \websockets: off\n",
+          mkServerConfig = \_storeLogFile transports _ ->
+            NtfServerConfig
+              { transports,
+                subIdBytes = 24,
+                regCodeBytes = 32,
+                clientQSize = 16,
+                subQSize = 64,
+                pushQSize = 128,
+                smpAgentCfg = defaultSMPClientAgentConfig,
+                apnsConfig = defaultAPNSPushClientConfig,
+                inactiveClientExpiration = Nothing,
+                caCertificateFile = caCrtFile,
+                privateKeyFile = serverKeyFile,
+                certificateFile = serverCrtFile
+              }
+        }

apps/smp-agent/Main.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -9,7 +8,6 @@ import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Server (runSMPAgent)
-import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
@@ -19,8 +17,7 @@ servers :: InitialAgentServers
 servers =
   InitialAgentServers
     { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = [],
-      netCfg = defaultNetworkConfig
+      ntf = []
     }
 
 logCfg :: LogConfig

apps/smp-server/Main.hs

@@ -1,7 +1,20 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Main where
 
 import Control.Logger.Simple
-import Simplex.Messaging.Server.Main
+import Data.Functor (($>))
+import Data.Ini (lookupValue)
+import Simplex.Messaging.Server (runSMPServer)
+import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
+import System.FilePath (combine)
 
 cfgPath :: FilePath
 cfgPath = "/etc/opt/simplex"
@@ -14,5 +27,82 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  setLogLevel LogDebug
-  withGlobalLogging logCfg $ smpServerCLI cfgPath logPath
+  setLogLevel LogInfo
+  withGlobalLogging logCfg . protocolServerCLI smpServerCLIConfig $ \cfg@ServerConfig {inactiveClientExpiration} -> do
+    putStrLn $ case inactiveClientExpiration of
+      Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
+      _ -> "not expiring inactive clients"
+    runSMPServer cfg
+
+smpServerCLIConfig :: ServerCLIConfig ServerConfig
+smpServerCLIConfig =
+  let caCrtFile = combine cfgPath "ca.crt"
+      serverKeyFile = combine cfgPath "server.key"
+      serverCrtFile = combine cfgPath "server.crt"
+   in ServerCLIConfig
+        { cfgDir = cfgPath,
+          logDir = logPath,
+          iniFile = combine cfgPath "smp-server.ini",
+          storeLogFile = combine logPath "smp-server-store.log",
+          caKeyFile = combine cfgPath "ca.key",
+          caCrtFile,
+          serverKeyFile,
+          serverCrtFile,
+          fingerprintFile = combine cfgPath "fingerprint",
+          defaultServerPort = "5223",
+          executableName = "smp-server",
+          serverVersion = "SMP server v" <> simplexMQVersion,
+          mkIniFile = \enableStoreLog defaultServerPort ->
+            "[STORE_LOG]\n\
+            \# The server uses STM memory for persistence,\n\
+            \# that will be lost on restart (e.g., as with redis).\n\
+            \# This option enables saving memory to append only log,\n\
+            \# and restoring it when the server is started.\n\
+            \# Log is compacted on start (deleted objects are removed).\n"
+              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n")
+              <> "# The messages are optionally saved and restored when the server restarts,\n\
+                 \# they are deleted after restarting.\n"
+              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+              <> "[TRANSPORT]\n"
+              <> ("port: " <> defaultServerPort <> "\n")
+              <> "websockets: off\n\n"
+              <> "[INACTIVE_CLIENTS]\n\
+                 \# TTL and interval to check inactive clients\n\
+                 \disconnect: off\n"
+              <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
+              <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
+          mkServerConfig = \storeLogFile transports ini ->
+            ServerConfig
+              { transports,
+                tbqSize = 16,
+                serverTbqSize = 64,
+                msgQueueQuota = 128,
+                queueIdBytes = 24,
+                msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
+                caCertificateFile = caCrtFile,
+                privateKeyFile = serverKeyFile,
+                certificateFile = serverCrtFile,
+                storeLogFile,
+                storeMsgsFile =
+                  let messagesPath = combine logPath "smp-server-messages.log"
+                   in case lookupValue "STORE_LOG" "restore_messages" ini of
+                        Right "on" -> Just messagesPath
+                        Right _ -> Nothing
+                        -- if the setting is not set, it is enabled when store log is enabled
+                        _ -> storeLogFile $> messagesPath,
+                allowNewQueues = True,
+                messageExpiration = Just defaultMessageExpiration,
+                inactiveClientExpiration =
+                  if lookupValue "INACTIVE_CLIENTS" "disconnect" ini == Right "on"
+                    then
+                      Just
+                        ExpirationConfig
+                          { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
+                            checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
+                          }
+                    else Nothing,
+                logStatsInterval = Just 86400, -- seconds
+                logStatsStartTime = 0, -- seconds from 00:00 UTC
+                smpServerVRange = supportedSMPServerVRange
+              }
+        }

build.Dockerfile

@@ -1,51 +0,0 @@
-FROM ubuntu:focal AS final
-FROM ubuntu:focal AS build
-
-### Build stage
-
-# Install curl and git and smp-related dependencies
-RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev
-
-# Install ghcup
-RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghcup && \
-    chmod +x /usr/bin/ghcup
-
-# Install ghc
-RUN ghcup install ghc 8.10.7
-# Install cabal
-RUN ghcup install cabal
-# Set both as default
-RUN ghcup set ghc 8.10.7 && \
-    ghcup set cabal
-
-COPY . /project
-WORKDIR /project
-
-# Adjust PATH
-ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
-
-# Compile smp-server
-RUN cabal update
-RUN cabal install
-
-### Final stage
-
-FROM final
-
-# Install OpenSSL dependency
-RUN apt-get update && apt-get install -y openssl
-
-# Copy compiled smp-server from build stage
-COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
-
-# Copy our helper script
-COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
-
-# Open smp-server listening port
-EXPOSE 5223
-
-# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
-STOPSIGNAL SIGINT
-
-# Finally, execute helper script
-ENTRYPOINT [ "/usr/bin/entrypoint" ]

cabal.project

@@ -1,17 +1,6 @@
 packages: .
--- packages: . ../direct-sqlcipher ../sqlcipher-simple
 
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/aeson.git
     tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
-
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/direct-sqlcipher.git
-    tag: 34309410eb2069b029b8fc1872deb1e0db123294
-
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/sqlcipher-simple.git
-    tag: 5e154a2aeccc33ead6c243ec07195ab673137221

download.Dockerfile

@@ -1,20 +0,0 @@
-FROM ubuntu:focal
-
-# Install curl
-RUN apt-get update && apt-get install -y curl
-
-# Download latest smp-server release and assign executable permission
-RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64 -o /usr/bin/smp-server && \
-	chmod +x /usr/bin/smp-server
-
-# Copy our helper script
-COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
-
-# Open smp-server listening port
-EXPOSE 5223
-
-# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
-STOPSIGNAL SIGINT
-
-# Finally, execute helper script
-ENTRYPOINT [ "/usr/bin/entrypoint" ]

img/linode.svg

@@ -1 +1 @@
-<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 4.3.1
+version: 2.3.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -28,7 +28,7 @@ dependencies:
   - asn1-types == 0.3.*
   - async == 2.2.*
   - attoparsec == 0.14.*
-  - base >= 4.14 && < 5
+  - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
   - bytestring == 0.10.*
   - case-insensitive == 1.2.*
@@ -38,25 +38,24 @@ dependencies:
   - cryptonite >= 0.27 && < 0.30
   - cryptostore == 0.2.*
   - data-default == 0.7.*
-  - direct-sqlcipher == 2.3.*
+  - direct-sqlite == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
   - http2 == 3.0.*
   - generic-random >= 1.3 && < 1.5
-  - ini == 0.4.1
+  - ini == 0.4.*
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
   - network >= 3.1.2.7 && < 3.2
-  - network-transport == 0.5.4
+  - network-transport == 0.5.*
   - optparse-applicative >= 0.15 && < 0.17
   - QuickCheck == 2.14.*
   - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
-  - socks == 0.6.*
-  - sqlcipher-simple == 0.4.*
+  - sqlite-simple == 0.4.*
   - stm == 2.5.*
   - template-haskell == 2.16.*
   - text == 1.2.*
@@ -65,6 +64,7 @@ dependencies:
   - time-manager == 0.0.*
   - tls >= 1.6.0 && < 1.7
   - transformers == 0.5.*
+  - unix == 2.7.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
   - websockets == 0.12.*
@@ -121,8 +121,6 @@ tests:
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
       - QuickCheck == 2.14.*
-      - silently == 1.2.*
-      - main-tester == 0.2.*
       - timeit == 2.0.*
 
 ghc-options:

protocol/simplex-messaging.md

@@ -24,7 +24,6 @@
     - [Subscribe to queue](#subscribe-to-queue)
     - [Secure queue command](#secure-queue-command)
     - [Enable notifications command](#enable-notifications-command)
-    - [Disable notifications command](#disable-notifications-command)
     - [Acknowledge message delivery](#acknowledge-message-delivery)
     - [Suspend queue](#suspend-queue)
     - [Delete queue](#delete-queue)
@@ -51,8 +50,6 @@ It's designed with the focus on communication security and integrity, under the
 
 It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
 
-This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
-
 ## Introduction
 
 The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
@@ -149,61 +146,61 @@ To create and start using a simplex queue Alice and Bob follow these steps:
 
 1. Alice creates a simplex queue on the server:
 
-   1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
+    1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
 
-   2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
+    2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
 
-   3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
+    3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
 
-   4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
+    4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
 
-   5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
+    5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
 
-   6. The server sends `"IDS"` response with queue IDs (`queueIds`):
+    6. The server sends `"IDS"` response with queue IDs (`queueIds`):
 
-      - Recipient ID `RID` for Alice to manage the queue and to receive the messages.
+        - Recipient ID `RID` for Alice to manage the queue and to receive the messages.
 
-      - Sender ID `SID` for Bob to send messages to the queue.
+        - Sender ID `SID` for Bob to send messages to the queue.
 
-      - Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
+        - Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
 
 2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include:
 
-   - Unique "public" key (`EK`) that Bob must use for E2E key agreement.
+    - Unique "public" key (`EK`) that Bob must use for E2E key agreement.
 
-   - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
+    - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
 
-   - Sender queue ID `SID` for Bob to use.
+    - Sender queue ID `SID` for Bob to use.
 
 3. Bob, having received the out-of-band message from Alice, connects to the queue:
 
-   1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
+    1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
 
-   2. Prepares the confirmation message for Alice to secure the queue. This message includes:
+    2. Prepares the confirmation message for Alice to secure the queue. This message includes:
 
-      - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
+        - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
 
-      - Optionally, any additional information (application specific, e.g. Bob's profile name and details).
+        - Optionally, any additional information (application specific, e.g. Bob's profile name and details).
 
-   3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
+    3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
 
-   4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
+    4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
 
 4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)):
 
-   1. She decrypts received message body using the secret `SS`.
+    1. She decrypts received message body using the secret `SS`.
 
-   2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
+    2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
 
-   3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
+    3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
 
 5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
 
-   1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
+    1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
 
-   2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
+    2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
 
-   3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
+    3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
 
 6. The simplex queue `RID` is now ready to be used.
 
@@ -217,21 +214,21 @@ Bob now can securely send messages to Alice:
 
 1. Bob sends the message:
 
-   1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
+    1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
 
-   2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
+    2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
 
-   3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
+    3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
 
 2. Alice receives the message(s):
 
-   1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
+    1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
 
-   2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
+    2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
 
-   3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
+    3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
 
-   4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
+    4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
 
 This flow is show on sequence diagram below.
 
@@ -358,22 +355,18 @@ To protect the privacy of the recipients, there are several commands in SMP prot
 The clients can optionally instruct a dedicated push notification server to subscribe to notifications and deliver push notifications to the device, which can then retrieve the messages in the background and send local notifications to the user - this is out of scope of SMP protocol. The commands that SMP protocol provides to allow it:
 
 - `enableNotifications` (`"NKEY"`) with `notifierId` (`"NID"`) response - see [Enable notifications command](#enable-notifications-command).
-- `disableNotifications` (`"NDEL"`) - see [Disable notifications command](#disable-notifications-command).
 - `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
 - `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
 
-[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
-
-## SMP Transmission andtransport block structure
+## SMP Transmission structure
 
 Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
 
-From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
 Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
 
 In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
 
-```abnf
+```
 paddedString = originalLength string pad
 originalLength = 2*2 OCTET
 pad = N*N"#" ; where N = paddedLength - originalLength - 2
@@ -383,9 +376,9 @@ paddedNotation = <padded(string, paddedLength)>
 ; paddedLength - required length after padding, including 2 bytes for originalLength
 ```
 
-Each transmission/block for SMP v3 between the client and the server must have this format/syntax:
+Each transmission between the client and the server must have this format/syntax:
 
-```abnf
+```
 paddedTransmission = <padded(transmission), 16384>
 transmission = [signature] SP signed
 signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
@@ -402,23 +395,13 @@ encoded = <base64 encoded binary>
 
 `base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
 
-Transport block for SMP v4 has this syntax:
-
-```abnf
-paddedTransportBlock = <padded(transportBlock), 16384>
-transportBlock = transmissionCount transmissions
-transmissionCount = 1*1 OCTET ; equal or greater than 1
-transmissions = transmissionLength transmission [transmissions]
-transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
-```
-
 ## SMP commands
 
 Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
 
 ```abnf
 smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg
-recipientCmd = create / subscribe / secure / enableNotifications / disableNotifications /
+recipientCmd = create / subscribe / secure / enableNotifications /
                acknowledge / suspend / delete
 serverMsg = queueIds / message / notifierId / messageNotification /
             unsubscribed / ok / error
@@ -519,42 +502,22 @@ Once the queue is secured only signed messages can be sent to it.
 This command is sent by the recipient to the server to add notifier's key to the queue, to allow push notifications server to receive notifications when the message arrives, via a separate queue ID, without receiving message content.
 
 ```abnf
-enableNotifications = %s"NKEY " notifierKey recipientNotificationDhPublicKey
+enableNotifications = %s"NKEY " notifierKey
 notifierKey = length x509encoded
 ; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue
-
-recipientNotificationDhPublicKey = length x509encoded
-; the recipient's Curve25519 key for DH exchange to derive the secret
-; that the server will use to encrypt notification metadata (encryptedNMsgMeta in NMSG)
-; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
 ```
 
 The server will respond with `notifierId` response if notifications were enabled and the notifier's key was successfully added to the queue:
 
 ```abnf
-notifierId = %s"NID " notifierId srvNotificationDhPublicKey
+notifierId = %s"NID " notifierId
 notifierId = length *OCTET ; 16-24 bytes
-srvNotificationDhPublicKey = length x509encoded
-; the server's Curve25519 key for DH exchange to derive the secret
-; that the server will use to encrypt notification metadata to the recipient (encryptedNMsgMeta in NMSG)
 ```
 
 This response is sent with the recipient's queue ID (the third part of the transmission).
 
 To receive the message notifications, `subscribeNotifications` command ("NSUB") must be sent signed with the notifier's key.
 
-#### Disable notifications command
-
-This command is sent by the recipient to the server to remove notifier's credentials from the queue:
-
-```abnf
-disableNotifications = %s"NDEL"
-```
-
-The server must respond `ok` to this command if it was successful.
-
-Once notifier's credentials are removed server will no longer send "NMSG" for this queue to notifier.
-
 #### Acknowledge message delivery
 
 The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted:
@@ -602,9 +565,7 @@ Currently SMP defines only one command that can be used by senders - `send` mess
 This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured:
 
 ```abnf
-send = %s"SEND " msgFlags SP smpEncMessage
-msgFlags = notificationFlag reserved
-notificationFlag = %s"T" / %s"F"
+send = %s"SEND " smpEncMessage
 smpEncMessage = smpPubHeader sentMsgBody ; message up to 16088 bytes
 smpPubHeader = smpClientVersion ("1" senderPublicDhKey / "0")
 smpClientVersion = word16
@@ -746,11 +707,9 @@ See its syntax in [Create queue command](#create-queue-command)
 The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is:
 
 ```abnf
-message = %s"MSG " msgId encryptedRcvMsgBody
+message = %s"MSG " msgId SP timestamp SP encryptedMsgBody
 encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
 paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 16088
-encryptedRcvMsgBody = <encrypt rcvMsgBody> ; server-encrypted meta-data and padded sent msgBody
-rcvMsgBody = timestamp msgFlags SP paddedSentMsgBody
 msgId = length 24*24OCTET
 timestamp = 8*8OCTET
 ```
@@ -776,19 +735,10 @@ See its syntax in [Enable notifications command](#enable-notifications-command)
 The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command ("NSUB") on the currently open transport connection. The syntax for the message notification delivery is:
 
 ```abnf
-messageNotification = %s"NMSG " nmsgNonce encryptedNMsgMeta
-
-encryptedNMsgMeta = <encrypted message metadata passed in notification>
-; metadata E2E encrypted between server and recipient containing server's message ID and timestamp (allows extension),
-; to be passed to the recipient by the notifier for them to decrypt
-; with key negotiated in NKEY and NID commands using nmsgNonce
-
-nmsgNonce = <nonce used in NaCl crypto_box encryption scheme>
-; nonce used by the server for encryption of message metadata, to be passed to the recipient by the notifier
-; for them to use in decryption of E2E encrypted metadata
+messageNotification = %s"NMSG"
 ```
 
-Message notification does not contain any message data or non E2E encrypted metadata.
+Message notification does not contain any message data or meta-data, it only notifies that the message is available.
 
 #### Subscription END notification
 
@@ -842,7 +792,6 @@ ok = %s"OK"
 Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223.
 
 For scenarios when meta-data privacy is critical, it is recommended that clients:
-
 - communicating over Tor network,
 - establish a separate connection for each SMP queue,
 - send noise traffic (using PING command).
@@ -850,14 +799,12 @@ For scenarios when meta-data privacy is critical, it is recommended that clients
 In addition to that, the servers can be deployed as Tor onion services.
 
 The transport protocol should provide the following:
-
 - server authentication (by matching server certificate hash with `serverIdentity`),
 - forward secrecy (by encrypting the traffic using ephemeral keys agreed during transport handshake),
 - integrity (preventing data modification by the attacker without detection),
 - unique channel binding (`sessionIdentifier`) to include in the signed part of SMP transmissions.
 
 By default, the client and server communicate using [TLS 1.3 protocol][13] restricted to:
-
 - TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices),
 - ed25519 and ed448 EdDSA algorithms for signatures,
 - x25519 and x448 ECDHE groups for key exchange.

rfcs/2022-12-26-simplex-file-transfer.md

@@ -1,161 +0,0 @@
-# SimpleX File Transfer protocol
-
-## Problem
-
-Sending files as currently implemented in SimpleX Chat is inefficient for these reasons:
-
-1. Slow: message delivery requires acknowledgement for each message before the server sends the next message.
-2. Not fully asynchronous:
-   a. SMP queue size is limited, so the whole file cannot be sent/stored in server memory.
-   b. Recipient needs to accept the file before it is sent.
-3. No broadcast: sending the same file to multiple recipients requires sending it multiple times.
-
-## Possible solutions
-
-These problems could be solved within SMP protocol:
-
-- streaming messages without waiting for acknowledgements.
-- bigger queue sizes stored on hard drive and accepting large files without waiting for the recipient confirmation.
-- adding broadcast to SMP servers.
-
-These solution are complex and they do not scale well.
-
-Another approach would be adopting some open-source file storage, possibly S3-compatible, to host files while "in transit". The downsides are:
-
-1. Missing features. S3-compatible file servers require a service layer that we would need to develop to manage user accounts and permissions. There are solutions that allow self-registering users and uploading files without service layer, but they are not flexible enough in managing policies for these files.
-2. Limited meta-data protection, both on the application and on transport layer: same address for sending and receiving a file, file size is known to the server, etc.
-3. More difficult to self-host for the users when the server has 2 components (a 3rd party solution with our service component).
-
-We are not considering P2P solutions because of their bad meta-data privacy and requirement of having a single network - the same reason why P2P design is not used for SimpleX messaging network.
-
-A proposed solution is to develop a file hosting service (SimpleX File Transfer service) that would have better meta-data protection and functionality than the alternatives, using the ideas from SMP protocol design.
-
-The parameters of the solution would be:
-
-1. The server does not have knowledge of the users and actual files – only anonymously uploaded fixed-size chunks (considered 8Mb, maybe we should allow 2 sizes, e.g. 1Mb and 8Mb).
-2. The server should allow broadcast, so that a chunk can be downloaded by multiple recipients.
-3. There should be no identifiers and ciphertext in common inside TLS between sender and recipient traffic, and between the traffic of different recipients of the same file. This approach can be extended to support public chunks that have persistent identifiers.
-4. The server should prevent multiple uploads of the same chunk. This can be extended to allow multiple downloads from the same persistent address.
-5. Clients can send the chunks from the same file via multiple servers, both by splitting chunks between them and for redundancy.
-
-## Design approach
-
-File transfer servers will be chosen by file senders. The servers will allow senders to anonymously upload fixed-size file chunks.
-
-### Transport protocol
-
-- binary-encoded commands sent as fixed-size padded block in the body of HTTP2 POST request, similar to SMP and notifications server protocol transmission encodings.
-- HTTP2 POST with a fixed size padded block body for file upload and download.
-
-Block size - 4096 bytes (it would fit ~120 Ed25519 recipient keys).
-
-The reasons to use HTTP2:
-
-- avoid the need to have two hostnames (or two different ports) for commands and file uploads.
-- compatibility with the existing HTTP2 client libraries.
-
-The reason not to use JSON bodies:
-
-- bigger request size, so fewer recipient keys would fit in a single request
-- signature over command has to be outside of JSON anyway.
-
-The reason not to use URI segments / HTTP verbs / REST semantics is to have consistent request size.
-
-### Required server commands:
-
-- File sender:
-  - create file chunk record.
-    - Parameters:
-      - Ed25519 key for subsequent sender commands and Ed25519 keys for commands of each recipient.
-      - chunk size.
-    - Response:
-      - chunk ID for the sender and different IDs for all recipients.
-  - add recipients to file chunk
-    - Parameters:
-      - sender's chunk ID
-      - Ed25519 keys for commands of each recipient.
-    - Response:
-      - chunk IDs for new recipients.
-  - upload file chunk.
-  - delete file chunk (invalidates all recipient IDs).
-- File recipient:
-  - download file chunk:
-    - chunk ID
-    - DH key for additional encryption of the chunk.
-    - command should be signed with the key passed by the sender when creating chunk record.
-  - delete file chunk ID (only for one recipient): signed with the same key.
-
-### Storage model
-
-Same as for SMP and notifications server - in-memory storage of the records, with adding to append-only log, restored and compacted on server restart.
-
-### Sending file
-
-To send the file, the sender will:
-
-- compute SHA512 digest
-- pad the file to match the whole number of chunks in size,
-- encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL crypto_secretbox),
-- split into fixed size chunks
-- upload each chunk to a randomly chosen server.
-
-The sending client should generate more per-recipient keys than the actual number of recipients, possibly rounding up to a power of 2, to conceal the actual number of intended recipients.
-
-Then the sending client will combine addresses of all chunks and other information into "file description", different for each file recipient, that will include:
-
-- an encryption key that was used to encrypt the file (the same for all recipients).
-- file SHA512 digest
-- list of chunk descriptions; information for each chunk:
-  - private Ed25519 key to sign commands for file transfer server.
-  - chunk address (server host and chunk ID).
-  - chunk sha512 digest
-
-To reduce the size, chunk descriptions will be grouped by the server host.
-
-This "file description" itself will be sent as a small file over an authenticated channel, to prevent file description modification. To estimate its size:
-
-- each chunk \* redundancy per chunk, assuming chunks are grouped per server:
-  - 1-based chunk number in the file - 8 bytes (including any overhead)
-  - Ed25519 key (different for each recipient / chunk combination) - 32 bytes \* 4/3 (base64, assuming text encoding)
-  - chunk ID (different for each recipient) - 64 bytes \* 4/3
-  - optional (only in the first chunk occurence) chunk sha512 digests - 64 bytes \* 4/3
-- server addresses - say, 128 bytes per server
-- sha512 digest - 64 bytes \* 4/3
-- encryption key - 32 bytes \* 4/3
-- IV - 32 bytes \* 4/3
-- encoding overhead - say, 256 bytes
-
-For 1gb file, sent via 4 different servers, in 8Mb chunks, with redundancy 2, the size of "file description", assuming text encoding, will be ~45kb (`128 * (8 + 32 + 64) * 2 * 4/3 + 128 * 64 * 4/3 + 128 * 4 + (64 + 32 + 32) * 4/3 + 256`).
-
-File description format (yml):
-
-```
-name: file.ext
-size: 33200000
-chunk: 8Mb
-hash: abc=
-key: abc=
-iv: abc=
-part_hashes: [def=, def=, def=, def=]
-parts:
-  - server: xftp://[email protected]
-    chunks: [1:abc=:def=:ghi=, 3:abc=:def=:ghi=]
-  - server: xftp://[email protected]
-    chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=]
-  - server: xftp://[email protected]
-    chunks: [1:abc=:def=, 4:abc=:def=]
-  - server: xftp://[email protected]
-    chunks: [2:abc=:def=, 3:abc=:def=]
-```
-
-This file description is sent to all recipients via normal messages, split to 15780 byte chunks if needed.
-
-### Receiving file
-
-Having received the description, the recipient will:
-
-- download all chunks falling back to secondary servers, if needed
-- combine the chunks into a file
-- decrypt the file
-- un-pad it
-- validate file digest

rfcs/2022-12-27-queue-quota.md

@@ -1,20 +0,0 @@
-# SMP and SMP agent protocol extensions to manage queue quotas
-
-## Problem
-
-SMP servers define a limit on the number of messages that can be stored on the server. When the sender reaches this limit, they continue trying to send the message with exponential back off, until the server allows it. To reduce the traffic we added expiration on unsent messages of 2 days that:
-
-- adds its own set of problems because of expired control messages - e.g., group fragmentation.
-- doesn't solve problem of traffic in active groups with many inactive members - there are still too many retries in queues that reached capacity.
-
-## Solution
-
-Sending agent permanently stops trying to send messages having received `ERR QUOTA` (or, for the period of clients migration, increases TTL much more than in cases of network errors).
-
-Add SMP server event that means "quota reached" (e.g. `QTA` or `MSG QUOTA`) - it will be delivered to the recipient once all messages are retrieved at the same point in message stream where the sender received `ERR QUOTA`. Alternatively, it could be a message flag that is set on the last message in the queue at a point the sender received `ERR QUOTA`.
-
-Add SMP agent message that means "quota available, resume sending" (e.g. `A_QTA` or `A_RESUME`) – the receiving agent will send it via the reply queue to the sending agent that will resume sending messages at this point.
-
-Possibly, increase TTL for local messages to 30 days. That might require separately addressing the problem of permanently failing servers.
-
-We discussed a possible solution of merging all messages to one server into one delivery queue, so that having multiple failing queues on this server will not result in multiple connection attempts, and this proposal also answers the question what to do with the messages when quota is exceeded - the whole queue can be marked as suspended, and processed separately from others - TBD.

rfcs/done/2022-07-22-access-via-tor.md

@@ -1,26 +0,0 @@
-# Accessing SMP servers via Tor
-
-## Problem
-
-While SMP protocol is focussed on minimizing application-level meta-data by using pair-wise identifiers instead of user profile identifiers, it is important for many users to protect their IP addresses.
-
-Further, even if IP addresses are hidden by onion routing, clients should be able to choose to use a separate TCP connection to subscribe to each queue, even though it increases traffic and battery consumption, as otherwise the servers can observe multiple queues accessed by the same client.
-
-## Solution and requirements
-
-While some users may want to access SMP servers via tor, some other users (even their contacts) may want the opposite - e.g., if they use the network when accessing Tor would be suspicious (or blocked).
-
-Therefore we need to support the connections when one of the user accesses the same server via Tor (and, possibly, via onion address), while another user accesses this server without Tor.
-
-At the same time the user accessing the server via Tor may not want that their contacts access this server without Tor, and it also may be possible that the server is not available under a normal (not .onion) address.
-
-The proposed options for connecting via Tor are:
-
-1. Access servers via Socks proxy: no/yes (specify port?)
-2. Use .onion addresses: no/when available/warn/always
-3. Require senders to use .onion addresses: yes/no
-4. Use separate TCP connection for each queue
-
-While it should be possible for SMP servers to have two addresses (with and without Tor), the queues should only use one server address - if the queue started being accessed via .onion address it should not be possible to access it via a normal address. Queue addresses in connection invitations should support dual server addresses (when senders are not required ot use .onion address).
-
-At the same time, the queue with the normal addresses can be accessed with and without Tor, depending on the current device settings.

rfcs/done/2022-08-14-queue-rotation.md

@@ -1,53 +0,0 @@
-# SMP queue rotation and redundancy
-
-## Problem
-
-1. Long term usage of the queue allows the servers to analyze long term traffic patterns.
-
-2. If the user changes the configured SMP server(s), the previously created contacts do not migrate to the new server(s).
-
-3. Server can lose messages.
-
-## Solution
-
-Additional messages exchanged by SMP agents to negotiate addition and removal of queues to the connection.
-
-This approach allows for both rotation and redundancy, as changing queue will be done be adding a queue and then removing the existing queue.
-
-The reason for this approach is that otherwise it's non-trivial to switch from one queue to another without losing messages or delivering them out of order, it's easier to have messages delivered via both queues during the switch, however short or long time it is.
-
-### Messages
-
-Additional agent messages required for the protocol:
-
-    QADD_ -> "QA"
-    QKEY_ -> "QK"
-    QUSE_ -> "QU"
-    QTEST_ -> "QT"
-
-`QADD`: add the new queue address(es), the same format as `REPLY` message, encoded as `QA`.
-
-`QKEY`: pass sender's key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker), encoded as `QK`.
-
-`QUSE`: instruct the sender to use the new queue with sender's queue ID as parameter, encoded as `QU`.
-
-`QTEST`: send test message to the new connection, encoded as `QT`. Any other message can be sent if available to continue rotation, the absence of this message is not an error. Once this message is successfully sent the sender will stop using the old queue. Once this message (or any other message in the new queue) is received, the recipient will stop using the old queue and delete it.
-
-### Protocol
-
-```
-participant A as Alice
-participant B as Bob
-participant R as Server that has A's receive queue
-participant S as Server that has A's send queue (B's receive queue)
-participant R' as Server that hosts the new A's receive queue
-
-A ->> R': create new queue
-A ->> S ->> B: QADD (R'): snd address of the new queue(s)
-B ->> S(R) ->> A: QKEY (R'): sender's key for the new queue(s) (to avoid the race of SMP confirmation for the initial exchange)
-A ->> S(R'): secure new queue
-A ->> S ->> B: QUSE (R'): instruction to use new queue(s)
-B ->> S(R') ->> A: QTEST
-A ->> S(R): DEL: delete the old queue
-B ->> S(R') ->> A: send all new messages to the new queue
-```

rfcs/done/2022-11-11-smp-basic-auth.md

@@ -1,27 +0,0 @@
-# SMP Basic Auth
-
-## Problem
-
-Users who host their own servers do not want unknown people to be able to create messaging queues on their servers after discovering server address in groups or after making a connection. As the number of self-hosted servers is growing it became more important than it was when we excluded it from the original design.
-
-## Solution
-
-Single access password that can be optionally included in server address that is passed to app configuration. It will not be allowed in the existing contexts (and parsing will fail), to avoid accidentally leaking it. Server address with password will look this way: `smp://fingerprint:password@hosts`
-
-## Implementation plan
-
-1. A separate type to include server and password, so it can only be used where allowed.
-
-2. Server password to create queues will be configured in TRANSPORT section of INI file, as `create_password` parameter.
-
-3. The password will only be required in server configuration/address to create queues only, it won't be required for other receiving queue operations on already existing queues.
-
-4. If new command is attempted in the session that does not allow creating queues, the server will send `ERR AUTH` response
-
-5. Passing password to the server can be done in one of the several ways, we need to decide:
-
-  - as a parameter of NEW command. Pros: a local change, that only needs checking when queue is created. Cons: protocol version change.
-  - as a separate command AUTH. Pros: allows to include additional parameters and potentially be extended beyond basic auth. Cons: more complex to manage server state, can be more difficult syntax in the future, if extended.
-  - as part of handshake (we currently ignore the unparsed part of handshake block, so it can be extended). Pros: probably, the simplest, and independent of the commands protocol – establishes create permission for the current session. Cons: the client won't know about whether it is able to create the queue until it tries (same as in case 1).
-
-  My preference is the last option. As a variant of the last option, we can add a server response/message that includes permission to create queues - it will only be sent to the clients who pass credential in handshake - that might simplify testing server connection (we currently do not do it). It might be unnecessary, as we could simply create and delete queue in case credential is passed as part of testing connection (and even sending a message to it).

scripts/docker/entrypoint

@@ -1,29 +0,0 @@
-#!/usr/bin/env sh
-confd="/etc/opt/simplex"
-logd="/var/opt/simplex/"
-
-# Check if server has been initialized
-if [ ! -f "$confd/smp-server.ini" ]; then
-  # If not, determine ip or domain
-  case $addr in
-    '') printf "Please specify \$addr environment variable.\n"; exit 1 ;;
-    *[a-zA-Z]*) set -- -n $addr ;;
-    *) set -- --ip $addr ;;
-  esac
-
-  case $pass in
-    '') set -- "$@" --no-password ;;
-    *) set -- "$@" --password $pass ;;
-  esac
-
-  smp-server init -y -l "$@"
-fi
-
-# backup store log
-[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log.bak
-# rotate server log
-[ -f "$logd/smp-server.log" ] && mv "$logd"/smp-server.log "$logd"/smp-server-"$(date +'%FT%T')".log
-
-# Finally, run smp-sever. Notice that "exec" here is important:
-# smp-server replaces our helper script, so that it can catch INT signal
-exec smp-server start > "$logd"/smp-server.log 2>&1

scripts/ntf-server-linode.sh

@@ -1,178 +0,0 @@
-#!/bin/bash
-
-# <UDF name="enable_store_log" label="Store log - persist notification subscriptions to append only log and restore them upon server restart." default="on" oneof="on, off" />
-# <UDF name="api_token" label="Linode API token - enable Linode to create tags with server address, fingerprint and version. Note: minimal permissions token should have are read/write access to `linodes` (to create tags) and `domains` (to add A record for the third level domain if FQDN is provided)." default="" />
-# <UDF name="fqdn" label="FQDN (Fully Qualified Domain Name) - provide third level domain name (e.g. ntf.example.com). If provided use `ntf://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `ntf://fingerprint@IP` instead." default="" />
-# <UDF name="apns_key_id" label="APNS key ID." default="" />
-
-# Log all stdout output to stackscript.log
-exec &> >(tee -i /var/log/stackscript.log)
-
-# Uncomment next line to enable debugging features
-# set -xeo pipefail
-
-cd $HOME
-
-# https://superuser.com/questions/1638779/automatic-yess-to-linux-update-upgrade
-# https://superuser.com/questions/1412054/non-interactive-apt-upgrade
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  update
-
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  dist-upgrade
-
-# TODO install unattended-upgrades
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  install jq
-
-# Add firewall
-echo "y" | ufw enable
-
-# Open ports
-ufw allow ssh
-ufw allow https
-ufw allow 5223
-
-# Increase file descriptors limit
-echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
-echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
-echo 'root soft nofile unlimited' >> /etc/security/limits.conf
-echo 'root hard nofile unlimited' >> /etc/security/limits.conf
-
-# Download latest release
-bin_dir="/opt/simplex-notifications/bin"
-binary="$bin_dir/ntf-server"
-mkdir -p $bin_dir
-curl -L -o $binary https://github.com/simplex-chat/simplexmq/releases/latest/download/ntf-server-ubuntu-20_04-x86-64
-chmod +x $binary
-
-# / Add to PATH
-cat > /etc/profile.d/simplex.sh << EOF
-#!/bin/bash
-
-export PATH="$PATH:$bin_dir"
-
-EOF
-# Add to PATH /
-
-# Source and test PATH
-source /etc/profile.d/simplex.sh
-ntf-server --version
-
-# Initialize server
-init_opts=()
-
-[[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
-
-ip_address=$(curl ifconfig.me)
-init_opts+=(--ip $ip_address)
-
-[[ -n "$FQDN" ]] && init_opts+=(-n $FQDN)
-
-ntf-server init "${init_opts[@]}"
-
-# Server fingerprint
-fingerprint=$(cat /etc/opt/simplex-notifications/fingerprint)
-
-# Determine server address to specify in welcome script and Linode tag
-if [[ -n "$FQDN" ]]; then
-  server_address=$FQDN
-else
-  server_address=$ip_address
-fi
-
-# Set up welcome script
-on_login_script="/opt/simplex-notifications/on_login.sh"
-
-# / Welcome script
-cat > $on_login_script << EOF
-#!/bin/bash
-
-fingerprint=\$1
-server_address=\$2
-
-cat << EOF2
-********************************************************************************
-
-SimpleX notifications server address: ntf://\$fingerprint@\$server_address
-Check server status with: systemctl status ntf-server
-
-To keep this server secure, the UFW firewall is enabled.
-All ports are BLOCKED except 22 (SSH), 443 (HTTPS), 5223 (notifications server).
-
-********************************************************************************
-To stop seeing this message delete line - bash /opt/simplex-notifications/on_login.sh - from /root/.bashrc
-EOF2
-
-EOF
-# Welcome script /
-
-chmod +x $on_login_script
-echo "bash $on_login_script $fingerprint $server_address" >> /root/.bashrc
-
-# Create A record and update Linode's tags
-if [[ -n "$API_TOKEN" ]]; then
-  if [[ -n "$FQDN" ]]; then
-    domain_address=$(echo $FQDN | rev | cut -d "." -f 1,2 | rev)
-    domain_id=$(curl -H "Authorization: Bearer $API_TOKEN" https://api.linode.com/v4/domains \
-    | jq --arg da "$domain_address" '.data[] | select( .domain == $da ) | .id')
-    if [[ -n $domain_id ]]; then
-      curl \
-        -s -H "Content-Type: application/json" \
-        -H "Authorization: Bearer $API_TOKEN" \
-        -X POST -d "{\"type\":\"A\",\"name\":\"$FQDN\",\"target\":\"$ip_address\"}" \
-        https://api.linode.com/v4/domains/${domain_id}/records
-    fi
-  fi
-
-  version=$(ntf-server --version | cut -d ' ' -f 3-)
-
-  curl \
-    -s -H "Content-Type: application/json" \
-    -H "Authorization: Bearer $API_TOKEN" \
-    -X PUT -d "{\"tags\":[\"$server_address\",\"$fingerprint\",\"$version\"]}" \
-    https://api.linode.com/v4/linode/instances/$LINODE_ID
-fi
-
-# / Create systemd service
-cat > /etc/systemd/system/ntf-server.service << EOF
-[Unit]
-Description=SimpleX notifications server
-
-[Service]
-Environment="APNS_KEY_FILE=/etc/opt/simplex-notifications/AuthKey.p8"
-Environment="APNS_KEY_ID=$APNS_KEY_ID"
-Type=simple
-ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex-notifications/ntf-server.log 2>&1"
-KillSignal=SIGINT
-Restart=always
-RestartSec=10
-LimitNOFILE=1000000
-LimitNOFILESoft=1000000
-
-[Install]
-WantedBy=multi-user.target
-
-EOF
-# Create systemd service /
-
-# Start systemd service
-chmod 644 /etc/systemd/system/ntf-server.service
-sudo systemctl enable ntf-server
-# ! APNS key file and certificate have to be copied manually
-# sudo systemctl start ntf-server
-
-# Reboot Linode to apply upgrades
-# sudo reboot

scripts/smp-server-linode.sh

@@ -86,6 +86,10 @@ smp-server init "${init_opts[@]}"
 fingerprint=$(cat /etc/opt/simplex/fingerprint)
 
 # Determine server address to specify in welcome script and Linode tag
+# ! If FQDN was provided and used as part of server initialization, server's certificate will not pass validation at client
+# ! if client tries to connect by server's IP address, so we have to specify FQDN as server address in Linode tag and
+# ! in welcome script regardless of creation of A record in Linode
+# ! https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
 if [[ -n "$FQDN" ]]; then
   server_address=$FQDN
 else
@@ -154,7 +158,6 @@ Description=SMP server
 Type=simple
 ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
 KillSignal=SIGINT
-TimeoutStopSec=infinity
 Restart=always
 RestartSec=10
 LimitNOFILE=1000000

scripts/tor/README.md

@@ -1,37 +0,0 @@
-1. Install `tor` following [official guide](https://community.torproject.org/onion-services/setup/install/).
-
-2. Modify `/etc/tor/torrc` configuration file:
-
-```sh
-...
-# Disable anonymous mode for better connectivity
-## Needed for HiddenServiceNonAnonymousMode
-SOCKSPort 0
-## Needed for HiddenServiceSingleHopMode
-HiddenServiceNonAnonymousMode 1
-## Flag to disable anonymous mode
-## This option reduces the latency of server connection, but it makes server itself not anonymous,
-## it only protects the anonymity of the users connecting to the server.
-## In case your server address has both public and onion hostnames it is not anonymous anyway,
-## so this is what you want.
-HiddenServiceSingleHopMode 1
-
-# Specify folder for smp-tor
-## Folder for keys, address, etc.
-HiddenServiceDir /var/lib/tor/simplex-smp/
-## Map smp port (5223) to tor
-HiddenServicePort 5223 localhost:5223
-...
-```
-
-3. Restart `tor` system service:
-
-```
-sudo systemctl restart tor
-```
-
-4. Onion address can be obtained from following file:
-
-```sh
-sudo cat /var/lib/tor/simplex-smp/hostname
-```

simplexmq.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.0.
+-- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        4.3.1
+version:        2.3.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -37,7 +37,6 @@ library
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
-      Simplex.Messaging.Agent.Lock
       Simplex.Messaging.Agent.NtfSubSupervisor
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
@@ -50,12 +49,6 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
-      Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
@@ -66,25 +59,19 @@ library
       Simplex.Messaging.Notifications.Protocol
       Simplex.Messaging.Notifications.Server
       Simplex.Messaging.Notifications.Server.Env
-      Simplex.Messaging.Notifications.Server.Main
       Simplex.Messaging.Notifications.Server.Push.APNS
-      Simplex.Messaging.Notifications.Server.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.Env.STM
       Simplex.Messaging.Server.Expiration
-      Simplex.Messaging.Server.Main
       Simplex.Messaging.Server.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.STM
-      Simplex.Messaging.Server.Stats
       Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
@@ -110,7 +97,7 @@ library
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -120,24 +107,23 @@ library
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network-transport ==0.5.*
     , 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.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -146,15 +132,16 @@ library
     , time-manager ==0.0.*
     , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  default-language: Haskell2010
 
 executable ntf-server
   main-is: Main.hs
@@ -171,7 +158,7 @@ executable ntf-server
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -181,25 +168,24 @@ executable ntf-server
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network-transport ==0.5.*
     , 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.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -208,15 +194,16 @@ executable ntf-server
     , time-manager ==0.0.*
     , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  default-language: Haskell2010
 
 executable smp-agent
   main-is: Main.hs
@@ -233,7 +220,7 @@ executable smp-agent
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -243,25 +230,24 @@ executable smp-agent
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network-transport ==0.5.*
     , 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.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -270,15 +256,16 @@ executable smp-agent
     , time-manager ==0.0.*
     , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  default-language: Haskell2010
 
 executable smp-server
   main-is: Main.hs
@@ -295,7 +282,7 @@ executable smp-server
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -305,25 +292,24 @@ executable smp-server
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network-transport ==0.5.*
     , 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.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -332,15 +318,16 @@ executable smp-server
     , time-manager ==0.0.*
     , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  default-language: Haskell2010
 
 test-suite smp-server-test
   type: exitcode-stdio-1.0
@@ -353,11 +340,8 @@ test-suite smp-server-test
       AgentTests.NotificationTests
       AgentTests.SchemaDump
       AgentTests.SQLiteTests
-      CLITests
-      CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
-      CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
       NtfClient
       NtfServerTests
@@ -377,7 +361,7 @@ test-suite smp-server-test
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -387,7 +371,7 @@ test-suite smp-server-test
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
@@ -395,21 +379,18 @@ test-suite smp-server-test
     , hspec-core ==2.7.*
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
-    , main-tester ==0.2.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
-    , silently ==1.2.*
     , simple-logger ==0.1.*
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -419,12 +400,13 @@ test-suite smp-server-test
     , timeit ==2.0.*
     , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  default-language: Haskell2010

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

@@ -13,15 +13,13 @@
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
     AgentConfig (..),
-    AgentDatabase (..),
-    databaseFile,
     InitialAgentServers (..),
-    NetworkConfig (..),
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
+    AgentOperation (..),
+    disallowedOperations,
     newSMPAgentEnv,
-    createAgentStore,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
   )
@@ -33,7 +31,6 @@ import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
-import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
@@ -43,13 +40,10 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
-import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
+import Simplex.Messaging.Notifications.Client (NtfServer, NtfToken)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
-import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
@@ -59,74 +53,41 @@ import UnliftIO.STM
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServerWithAuth,
-    ntf :: [NtfServer],
-    netCfg :: NetworkConfig
+  { smp :: NonEmpty SMPServer,
+    ntf :: [NtfServer]
   }
 
-data AgentDatabase
-  = AgentDB SQLiteStore
-  | AgentDBFile {dbFile :: FilePath, dbKey :: String}
-
-databaseFile :: AgentDatabase -> FilePath
-databaseFile = \case
-  AgentDB SQLiteStore {dbFilePath} -> dbFilePath
-  AgentDBFile {dbFile} -> dbFile
-
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
     cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
-    database :: AgentDatabase,
+    dbFile :: FilePath,
+    dbSemName :: Maybe String,
     yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
-    messageRetryInterval :: RetryInterval2,
-    messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    ntfCron :: Word16,
-    ntfWorkerDelay :: Int,
-    ntfSMPWorkerDelay :: Int,
+    resubscriptionConcurrency :: Int,
+    ntfWorkerThrottle :: Int,
     ntfSubCheckInterval :: NominalDiffTime,
-    ntfMaxMessages :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    e2eEncryptVRange :: VersionRange,
-    smpAgentVRange :: VersionRange,
-    smpClientVRange :: VersionRange,
-    initialClientId :: Int
+    smpAgentVersion :: Version,
+    smpAgentVRange :: VersionRange
   }
 
 defaultReconnectInterval :: RetryInterval
 defaultReconnectInterval =
   RetryInterval
-    { initialInterval = 2_000000,
-      increaseAfter = 10_000000,
-      maxInterval = 180_000000
-    }
-
-defaultMessageRetryInterval :: RetryInterval2
-defaultMessageRetryInterval =
-  RetryInterval2
-    { riFast =
-        RetryInterval
-          { initialInterval = 1_000000,
-            increaseAfter = 10_000000,
-            maxInterval = 60_000000
-          },
-      riSlow =
-        -- TODO: these timeouts can be increased in v4.6 once most clients are updated
-        -- to resume sending on QCONT messages.
-        -- After that local message expiration period should be also increased.
-        RetryInterval
-          { initialInterval = 30_000000,
-            increaseAfter = 30_000000,
-            maxInterval = 600_000000
-          }
+    { initialInterval = second,
+      increaseAfter = 10 * second,
+      maxInterval = 10 * second
     }
+  where
+    second = 1_000_000
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
@@ -135,28 +96,23 @@ defaultAgentConfig =
       cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
       tbqSize = 64,
-      database = AgentDBFile {dbFile = "smp-agent.db", dbKey = ""},
+      dbFile = "smp-agent.db",
+      dbSemName = Nothing,
       yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
+      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
       reconnectInterval = defaultReconnectInterval,
-      messageRetryInterval = defaultMessageRetryInterval,
-      messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
-      ntfCron = 20, -- minutes
-      ntfWorkerDelay = 100000, -- microseconds
-      ntfSMPWorkerDelay = 500000, -- microseconds
+      resubscriptionConcurrency = 16,
+      ntfWorkerThrottle = 1000000, -- microseconds
       ntfSubCheckInterval = nominalDay,
-      ntfMaxMessages = 4,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
       privateKeyFile = "/etc/opt/simplex-agent/agent.key",
       certificateFile = "/etc/opt/simplex-agent/agent.crt",
-      e2eEncryptVRange = supportedE2EEncryptVRange,
-      smpAgentVRange = supportedSMPAgentVRange,
-      smpClientVRange = supportedSMPClientVRange,
-      initialClientId = 0
+      smpAgentVersion = currentSMPAgentVersion,
+      smpAgentVRange = supportedSMPAgentVRange
     }
 
 data Env = Env
@@ -165,22 +121,30 @@ data Env = Env
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
     randomServer :: TVar StdGen,
+    agentPhase :: TVar (AgentPhase, Bool),
+    agentOperations :: TMap AgentOperation Int,
     ntfSupervisor :: NtfSupervisor
   }
 
-newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} = do
-  idsDrg <- newTVarIO =<< drgNew
-  store <- case database of
-    AgentDB st -> pure st
-    AgentDBFile {dbFile, dbKey} -> liftIO $ createAgentStore dbFile dbKey yesToMigrations
-  clientCounter <- newTVarIO initialClientId
-  randomServer <- newTVarIO =<< liftIO newStdGen
-  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
-  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
+data AgentOperation = AONetwork | AODatabase
+  deriving (Eq, Ord)
 
-createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
-createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
+disallowedOperations :: AgentPhase -> [AgentOperation]
+disallowedOperations = \case
+  APActive -> []
+  APPaused -> [AONetwork]
+  APSuspended -> [AONetwork, AODatabase]
+
+newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
+newSMPAgentEnv config@AgentConfig {dbFile, dbSemName, yesToMigrations} = do
+  idsDrg <- newTVarIO =<< drgNew
+  store <- liftIO $ createSQLiteStore dbFile dbSemName Migrations.app yesToMigrations
+  clientCounter <- newTVarIO 0
+  randomServer <- newTVarIO =<< liftIO newStdGen
+  agentPhase <- newTVarIO (APActive, True)
+  agentOperations <- atomically TM.empty
+  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
+  return Env {config, store, idsDrg, clientCounter, randomServer, agentPhase, agentOperations, ntfSupervisor}
 
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
@@ -189,8 +153,7 @@ data NtfSupervisor = NtfSupervisor
     ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
   }
 
-data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
-  deriving (Show)
+data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCNtfWorker NtfServer
 
 newNtfSubSupervisor :: Natural -> STM NtfSupervisor
 newNtfSubSupervisor qSize = do

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,24 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Agent.Lock where
-
-import Control.Monad (void)
-import Control.Monad.IO.Unlift
-import Data.Functor (($>))
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-
-type Lock = TMVar String
-
-withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
-withLock lock name =
-  E.bracket_
-    (atomically $ putTMVar lock name)
-    (void . atomically $ takeTMVar lock)
-
-withGetLock :: MonadUnliftIO m => STM Lock -> String -> m a -> m a
-withGetLock getLock name a =
-  E.bracket
-    (atomically $ getLock >>= \l -> putTMVar l name $> l)
-    (atomically . takeTMVar)
-    (const a)

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -4,14 +4,12 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.NtfSubSupervisor
   ( runNtfSupervisor,
     nsUpdateToken,
     nsRemoveNtfToken,
     sendNtfSubCommand,
-    instantNotifications,
     closeNtfSupervisor,
     getNtfServer,
   )
@@ -19,132 +17,89 @@ where
 
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (stateTVar)
-import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
-import Control.Monad.Except
+import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Data.Bifunctor (first)
 import Data.Fixed (Fixed (MkFixed), Pico)
 import qualified Data.Map.Strict as M
-import Data.Text (Text)
 import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
+import Simplex.Messaging.Agent.Protocol (ConnId)
 import qualified Simplex.Messaging.Agent.Protocol as AP
-import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
-import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tshow, unlessM)
+import Simplex.Messaging.Util (unlessM)
 import System.Random (randomR)
 import UnliftIO (async)
 import UnliftIO.Concurrent (forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
-runNtfSupervisor c = do
+runNtfSupervisor :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runNtfSupervisor c = forever $ do
   ns <- asks ntfSupervisor
-  forever $ do
-    cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
-    handleError connId . agentOperationBracket c AONtfNetwork waitUntilActive $
-      runExceptT (processNtfSub c cmd) >>= \case
-        Left e -> notifyErr connId e
-        Right _ -> return ()
-  where
-    handleError :: ConnId -> m () -> m ()
-    handleError connId = E.handle $ \(e :: E.SomeException) -> do
-      logError $ "runNtfSupervisor error " <> tshow e
-      notifyErr connId e
-    notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
+  cmd <- atomically . readTBQueue $ ntfSubQ ns
+  runExceptT (processNtfSub c cmd) >>= \case
+    Left e -> liftIO $ print e
+    Right _ -> return ()
 
 processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
 processNtfSub c (connId, cmd) = do
-  logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
+  ntfServer_ <- getNtfServer c
   case cmd of
     NSCCreate -> do
-      (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
-        a <- liftIO $ getNtfSubscription db connId
-        q <- ExceptT $ getPrimaryRcvQueue db connId
-        pure (a, q)
-      logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
-      case a of
-        Nothing -> do
-          withNtfServer c $ \ntfServer -> do
-            case clientNtfCreds of
-              Just ClientNtfCreds {notifierId} -> do
-                let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
-                addNtfNTFWorker ntfServer
-              Nothing -> do
-                let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
-                addNtfSMPWorker smpServer
-        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
-          case (clientNtfCreds, ntfQueueId) of
-            (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
-              | sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
-              | otherwise -> rotate
-            (Nothing, Nothing) -> create
-            _ -> rotate
-          where
-            create :: m ()
-            create = case action_ of
-              -- action was set to NULL after worker internal error
-              Nothing -> resetSubscription
-              Just (action, _)
-                -- subscription was marked for deletion / is being deleted
-                | isDeleteNtfSubAction action -> do
-                  if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
-                    then resetSubscription
-                    else withNtfServer c $ \ntfServer -> do
-                      withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
-                      addNtfNTFWorker ntfServer
-                | otherwise -> case action of
-                  NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
-                  NtfSubSMPAction _ -> addNtfSMPWorker smpServer
-            rotate :: m ()
-            rotate = do
-              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
-              addNtfNTFWorker subNtfServer
-            resetSubscription :: m ()
-            resetSubscription =
-              withNtfServer c $ \ntfServer -> do
-                let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
-                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
-                addNtfSMPWorker smpServer
-    NSCDelete -> do
-      sub_ <- withStore' c $ \db -> do
-        supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
-        getNtfSubscription db connId
-      logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
-      case sub_ of
-        (Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
-        _ -> pure () -- err "NSCDelete - no subscription"
-    NSCSmpDelete -> do
-      withStore' c (`getPrimaryRcvQueue` connId) >>= \case
-        Right rq@RcvQueue {server = smpServer} -> do
-          logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
-          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
+      -- TODO merge getNtfSubscription and getRcvQueue into one method to read both in same transaction?
+      sub_ <- withStore c $ \st -> getNtfSubscription st connId
+      RcvQueue {notifierId, server = smpServer} <- withStore c $ \st -> getRcvQueue st connId
+      case (sub_, ntfServer_) of
+        (Nothing, Just ntfServer) -> do
+          currentTime <- liftIO getCurrentTime
+          case notifierId of
+            (Just nId) -> do
+              let newSub = newNtfSubscription connId smpServer (Just nId) ntfServer NASKey currentTime
+              withStore c $ \st -> createNtfSubscription st newSub (NtfSubAction NSACreate)
+            _ -> do
+              let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew currentTime
+              withStore c $ \st -> createNtfSubscription st newSub (NtfSubSMPAction NSAKey)
+          -- TODO optimize?
+          -- TODO - read action in getNtfSubscription and decide which worker to create
+          -- TODO - SMP worker can create Ntf worker on NKEY completion
           addNtfSMPWorker smpServer
-        _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer -> addNtfNTFWorker ntfServer
-    NSCNtfSMPWorker smpServer -> addNtfSMPWorker smpServer
+          addNtfWorker ntfServer
+        (Just _, Just ntfServer) -> do
+          -- TODO subscription may have to be updated depending on current state:
+          -- TODO - e.g., if it was previously marked for deletion action has to be updated
+          -- TODO - should action depend on subscription status or always be NSAKey (NSACreate if notifierId exists)
+          -- TODO   in case worker is currently deleting it? When deleting worker should check for updated_by_supervisor
+          -- TODO   and if it is set perform update instead of delete. If worker was not deleting it yet it should
+          -- TODO   idempotently replay commands.
+          addNtfSMPWorker smpServer
+          addNtfWorker ntfServer
+        _ -> pure () -- error - notification server not configured
+    NSCDelete -> do
+      -- TODO delete notifier ID and Key from SMP server (SDEL, then NDEL)
+      withStore c $ \st -> markNtfSubscriptionForDeletion st connId
+      case ntfServer_ of
+        (Just ntfServer) -> addNtfWorker ntfServer
+        _ -> pure ()
+    NSCNtfWorker ntfServer ->
+      addNtfWorker ntfServer
   where
-    addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
+    addNtfWorker = addWorker ntfWorkers runNtfWorker
     addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
     addWorker ::
-      (NtfSupervisor -> TMap (ProtocolServer s) (TMVar (), Async ())) ->
-      (AgentClient -> ProtocolServer s -> TMVar () -> m ()) ->
-      ProtocolServer s ->
+      (NtfSupervisor -> TMap ProtocolServer (TMVar (), Async ())) ->
+      (AgentClient -> ProtocolServer -> TMVar () -> m ()) ->
+      ProtocolServer ->
       m ()
     addWorker wsSel runWorker srv = do
       ws <- asks $ wsSel . ntfSupervisor
@@ -156,147 +111,95 @@ processNtfSub c (connId, cmd) = do
         Just (doWork, _) ->
           void . atomically $ tryPutTMVar doWork ()
 
-withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
-withNtfServer c action = getNtfServer c >>= mapM_ action
-
-runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
-runNtfWorker c srv doWork = do
-  delay <- asks $ ntfWorkerDelay . config
-  forever $ do
-    void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
-    threadDelay delay
-  where
-    runNtfOperation :: m ()
-    runNtfOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
-      logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
+runNtfWorker :: AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
+runNtfWorker c srv doWork = forever $ do
+  void . atomically $ readTMVar doWork
+  getNtfToken >>= \case
+    Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus} -> do
+      nextSub_ <- withStore c (`getNextNtfSubAction` srv)
+      ts <- liftIO getCurrentTime
       case nextSub_ of
         Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
-            processAction a
-              `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
+        Just (ntfSub@NtfSubscription {connId, smpServer, ntfSubId}, ntfSubAction, RcvQueue {ntfPrivateKey, notifierId}) ->
+          unlessM (rescheduleAction doWork ts ntfSub) $
+            case ntfSubAction of
+              NSACreate -> case (ntfPrivateKey, notifierId) of
+                (Just ntfPrivKey, Just nId)
+                  | ntfTknStatus == NTActive -> do
+                    nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer nId) ntfPrivKey
+                    let actionTs = addUTCTime 30 ts
+                    withStore c $ \st ->
+                      updateNtfSubscription st connId ntfSub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew, ntfSubActionTs = actionTs} (NtfSubAction NSACheck)
+                  | otherwise -> ntfInternalError c connId "NSACreate - token not active"
+                _ -> ntfInternalError c connId "NSACreate - no notifier key or ID"
+              NSACheck -> case ntfSubId of
+                Just nSubId ->
+                  agentNtfCheckSubscription c nSubId tkn >>= \case
+                    NSNew -> updateSubNextCheck NSNew
+                    NSPending -> updateSubNextCheck NSPending
+                    NSActive -> updateSubNextCheck NSActive
+                    NSEnd -> updateSubNextCheck NSEnd
+                    NSSMPAuth -> updateSub (NASCreated NSSMPAuth) (NtfSubAction NSADelete) ts
+                Nothing -> ntfInternalError c connId "NSACheck - no subscription ID"
+              NSADelete -> pure ()
+          where
+            updateSubNextCheck toStatus = do
+              checkInterval <- asks $ ntfSubCheckInterval . config
+              let nextCheckTs = addUTCTime checkInterval ts
+              updateSub (NASCreated toStatus) (NtfSubAction NSACheck) nextCheckTs
+            updateSub toStatus toAction actionTs =
+              withStore c $ \st ->
+                updateNtfSubscription st connId ntfSub {ntfSubStatus = toStatus, ntfSubActionTs = actionTs} toAction
+    _ -> noWorkToDo
+  delay <- asks $ ntfWorkerThrottle . config
+  liftIO $ threadDelay delay
+  where
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
-      ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
-        case action of
-          NSACreate ->
-            getNtfToken >>= \case
-              Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
-                case clientNtfCreds of
-                  Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
-                    nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
-                    -- possible improvement: smaller retry until Active, less frequently (daily?) once Active
-                    let actionTs' = addUTCTime 30 ts
-                    withStore' c $ \db ->
-                      updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
-                  _ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
-              _ -> workerInternalError c connId "NSACreate - no active token"
-          NSACheck ->
-            getNtfToken >>= \case
-              Just tkn ->
-                case ntfSubId of
-                  Just nSubId ->
-                    agentNtfCheckSubscription c nSubId tkn >>= \case
-                      NSAuth -> do
-                        getNtfServer c >>= \case
-                          Just ntfServer -> do
-                            withStore' c $ \db ->
-                              updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
-                            ns <- asks ntfSupervisor
-                            atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
-                          _ -> workerInternalError c connId "NSACheck - failed to reset subscription, notification server not configured"
-                      status -> updateSubNextCheck ts status
-                  Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
-              _ -> workerInternalError c connId "NSACheck - no active token"
-          NSADelete -> case ntfSubId of
-            Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` continueDeletion
-            _ -> continueDeletion
-            where
-              continueDeletion = do
-                let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
-                withStore' c $ \db -> updateNtfSubscription db sub' (NtfSubSMPAction NSASmpDelete) ts
-                ns <- asks ntfSupervisor
-                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
-          NSARotate -> case ntfSubId of
-            Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` deleteCreate
-            _ -> deleteCreate
-            where
-              deleteCreate = do
-                withStore' c $ \db -> deleteNtfSubscription db connId
-                ns <- asks ntfSupervisor
-                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
-      where
-        updateSubNextCheck ts toStatus = do
-          checkInterval <- asks $ ntfSubCheckInterval . config
-          let nextCheckTs = addUTCTime checkInterval ts
-          updateSub (NASCreated toStatus) (NtfSubNTFAction NSACheck) nextCheckTs
-        updateSub toStatus toAction actionTs' =
-          withStore' c $ \db ->
-            updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
 runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
-runNtfSMPWorker c srv doWork = do
-  delay <- asks $ ntfSMPWorkerDelay . config
-  forever $ do
-    void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
-    threadDelay delay
-  where
-    runNtfSMPOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
-      logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
+runNtfSMPWorker c srv doWork = forever $ do
+  void . atomically $ readTMVar doWork
+  getNtfToken >>= \case
+    Just NtfToken {ntfTknStatus} -> do
+      nextSub_ <- withStore c (`getNextNtfSubSMPAction` srv)
+      ts <- liftIO getCurrentTime
       case nextSub_ of
         Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
-            processAction a
-              `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
+        Just (ntfSub@NtfSubscription {connId, ntfServer}, ntfSubAction, rq@RcvQueue {ntfPublicKey}) ->
+          unlessM (rescheduleAction doWork ts ntfSub) $
+            case ntfSubAction of
+              NSAKey
+                | ntfTknStatus == NTActive ->
+                  case ntfPublicKey of
+                    Just ntfPubKey ->
+                      enableNotificationsWithNKey ntfPubKey
+                    _ -> do
+                      C.SignAlg a <- asks (cmdSignAlg . config)
+                      (ntfPubKey, ntfPrivKey) <- liftIO $ C.generateSignatureKeyPair a
+                      withStore c $ \st -> setRcvQueueNotifierKey st connId ntfPubKey ntfPrivKey
+                      enableNotificationsWithNKey ntfPubKey
+                | otherwise -> ntfInternalError c connId "NSAKey - token not active"
+                where
+                  enableNotificationsWithNKey ntfPubKey = do
+                    nId <- enableQueueNotifications c rq ntfPubKey
+                    withStore c $ \st -> do
+                      setRcvQueueNotifierId st connId nId
+                      updateNtfSubscription st connId ntfSub {ntfQueueId = Just nId, ntfSubStatus = NASKey, ntfSubActionTs = ts} (NtfSubAction NSACreate)
+                    ns <- asks ntfSupervisor
+                    atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
+    _ -> noWorkToDo
+  delay <- asks $ ntfWorkerThrottle . config
+  liftIO $ threadDelay delay
+  where
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
-      ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
-        case smpAction of
-          NSASmpKey ->
-            getNtfToken >>= \case
-              Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                rq <- withStore c (`getPrimaryRcvQueue` connId)
-                C.SignAlg a <- asks (cmdSignAlg . config)
-                (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
-                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
-                (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
-                let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
-                withStore' c $ \db -> do
-                  setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NtfSubNTFAction NSACreate) ts
-                ns <- asks ntfSupervisor
-                atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
-              _ -> workerInternalError c connId "NSASmpKey - no active token"
-          NSASmpDelete -> do
-            rq_ <- withStore' c $ \db -> do
-              setRcvQueueNtfCreds db connId Nothing
-              getPrimaryRcvQueue db connId
-            mapM_ (disableQueueNotifications c) rq_
-            withStore' c $ \db -> deleteNtfSubscription db connId
 
-rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
-rescheduleAction doWork ts actionTs
-  | actionTs <= ts = pure False
+rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> NtfSubscription -> m Bool
+rescheduleAction doWork ts NtfSubscription {ntfSubActionTs}
+  | ntfSubActionTs <= ts = pure False
   | otherwise = do
     void . atomically $ tryTakeTMVar doWork
     void . forkIO $ do
-      threadDelay $ diffInMicros actionTs ts
+      threadDelay $ diffInMicros ntfSubActionTs ts
       void . atomically $ tryPutTMVar doWork ()
     pure True
 
@@ -306,27 +209,10 @@ fromPico (MkFixed i) = i
 diffInMicros :: UTCTime -> UTCTime -> Int
 diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
 
-retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
-retryOnError c name loop done e = do
-  logError $ name <> " error: " <> tshow e
-  case e of
-    BROKER _ NETWORK -> retryLoop
-    BROKER _ TIMEOUT -> retryLoop
-    _ -> done e
-  where
-    retryLoop = do
-      atomically $ endAgentOperation c AONtfNetwork
-      atomically $ throwWhenInactive c
-      atomically $ beginAgentOperation c AONtfNetwork
-      loop
-
-workerInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
-workerInternalError c connId internalErrStr = do
-  withStore' c $ \db -> setNullNtfSubscriptionAction db connId
-  notifyInternalError c connId internalErrStr
-
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
+ntfInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
+ntfInternalError c@AgentClient {subQ} connId internalErrStr = do
+  withStore c $ \st -> setNullNtfSubscriptionAction st connId
+  atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
 
 getNtfToken :: AgentMonad m => m (Maybe NtfToken)
 getNtfToken = do
@@ -340,24 +226,19 @@ nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
 sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
-sendNtfSubCommand ns cmd = do
-  tkn <- readTVar (ntfTkn ns)
-  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
-
-instantNotifications :: Maybe NtfToken -> Bool
-instantNotifications = \case
-  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
-  _ -> False
+sendNtfSubCommand ns cmd =
+  readTVar (ntfTkn ns)
+    >>= mapM_ (\NtfToken {ntfTknStatus} -> when (ntfTknStatus == NTActive) $ writeTBQueue (ntfSubQ ns) cmd)
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do
   cancelNtfWorkers_ $ ntfWorkers ns
   cancelNtfWorkers_ $ ntfSMPWorkers ns
 
-cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
+cancelNtfWorkers_ :: TMap ProtocolServer (TMVar (), Async ()) -> IO ()
 cancelNtfWorkers_ wsVar = do
-  ws <- atomically $ stateTVar wsVar (,M.empty)
-  mapM_ (uninterruptibleCancel . snd) ws
+  ws <- atomically $ stateTVar wsVar $ \ws -> (ws, M.empty)
+  forM_ ws $ uninterruptibleCancel . snd
 
 getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do

src/Simplex/Messaging/Agent/QueryString.hs

@@ -24,16 +24,7 @@ instance StrEncoding QueryStringParams where
   strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
 
 queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a
-queryParam name q =
-  case queryParamStr name q of
-    Just p -> either fail pure $ parseAll strP p
+queryParam name (QSP _ q) =
+  case find ((== name) . fst) q of
+    Just (_, p) -> either fail pure $ parseAll strP p
     _ -> fail $ "no qs param " <> B.unpack name
-
-queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
-queryParam_ name q =
-  case queryParamStr name q of
-    Just p -> either fail pure $ parseAll strP p
-    _ -> pure Nothing
-
-queryParamStr :: ByteString -> QueryStringParams -> Maybe ByteString
-queryParamStr name (QSP _ q) = snd <$> find ((== name) . fst) q

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -1,21 +1,10 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Simplex.Messaging.Agent.RetryInterval
-  ( RetryInterval (..),
-    RetryInterval2 (..),
-    RetryIntervalMode (..),
-    withRetryInterval,
-    withRetryLock2,
-  )
-where
+module Simplex.Messaging.Agent.RetryInterval where
 
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Monad (void)
+import Control.Concurrent (threadDelay)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Simplex.Messaging.Util (whenM)
-import UnliftIO.STM
 
 data RetryInterval = RetryInterval
   { initialInterval :: Int,
@@ -23,51 +12,17 @@ data RetryInterval = RetryInterval
     maxInterval :: Int
   }
 
-data RetryInterval2 = RetryInterval2
-  { riSlow :: RetryInterval,
-    riFast :: RetryInterval
-  }
-
-data RetryIntervalMode = RISlow | RIFast
-  deriving (Eq)
-
 withRetryInterval :: forall m. MonadIO m => RetryInterval -> (m () -> m ()) -> m ()
-withRetryInterval ri action = callAction 0 $ initialInterval ri
+withRetryInterval RetryInterval {initialInterval, increaseAfter, maxInterval} action =
+  callAction 0 initialInterval
   where
     callAction :: Int -> Int -> m ()
-    callAction elapsed delay = action loop
+    callAction elapsedTime delay = action loop
       where
         loop = do
+          let newDelay =
+                if elapsedTime < increaseAfter || delay == maxInterval
+                  then delay
+                  else min (delay * 3 `div` 2) maxInterval
           liftIO $ threadDelay delay
-          let elapsed' = elapsed + delay
-          callAction elapsed' $ nextDelay elapsed' delay ri
-
--- This function allows action to toggle between slow and fast retry intervals.
-withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> ((RetryIntervalMode -> m ()) -> m ()) -> m ()
-withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
-  callAction (0, initialInterval riSlow) (0, initialInterval riFast)
-  where
-    callAction :: (Int, Int) -> (Int, Int) -> m ()
-    callAction slow fast = action loop
-      where
-        loop = \case
-          RISlow -> run slow riSlow (`callAction` fast)
-          RIFast -> run fast riFast (callAction slow)
-        run (elapsed, delay) ri call = do
-          wait delay
-          let elapsed' = elapsed + delay
-          call (elapsed', nextDelay elapsed' delay ri)
-        wait delay = do
-          waiting <- newTVarIO True
-          _ <- liftIO . forkIO $ do
-            threadDelay delay
-            atomically $ whenM (readTVar waiting) $ void $ tryPutTMVar lock ()
-          atomically $ do
-            takeTMVar lock
-            writeTVar waiting False
-
-nextDelay :: Int -> Int -> RetryInterval -> Int
-nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
-  if elapsed < increaseAfter || delay == maxInterval
-    then delay
-    else min (delay * 3 `div` 2) maxInterval
+          callAction (elapsedTime + delay) newDelay

src/Simplex/Messaging/Agent/Server.hs

@@ -48,7 +48,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
     smpAgent _ = do
       -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      runTransportServer started tcpPort tlsServerParams True $ \(h :: c) -> do
+      runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
         c <- getAgentClient initServers
         logConnection c True

src/Simplex/Messaging/Agent/Store.hs

@@ -3,30 +3,25 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Store where
 
+import Control.Concurrent.STM (TVar)
 import Control.Exception (Exception)
-import qualified Data.Attoparsec.ByteString.Char8 as A
+import Crypto.Random (ChaChaDRG)
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Kind (Type)
-import Data.List (find)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as L
 import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
-import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys)
+import Simplex.Messaging.Notifications.Client
+import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfTknStatus, NtfTokenId)
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgFlags,
@@ -35,20 +30,87 @@ import Simplex.Messaging.Protocol
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
     RcvDhSecret,
-    RcvNtfDhSecret,
     RcvPrivateSignKey,
     SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util ((<$?>))
 import Simplex.Messaging.Version
 
+-- * Store management
+
+-- | Store class type. Defines store access methods for implementations.
+class Monad m => MonadAgentStore s m where
+  -- Queue and Connection management
+  createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
+  createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
+  getConn :: s -> ConnId -> m SomeConn
+  getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn
+  deleteConn :: s -> ConnId -> m ()
+  upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()
+  upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()
+  setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
+  setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
+  setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
+  getRcvQueue :: s -> ConnId -> m RcvQueue
+
+  -- RcvQueue notifier key and ID
+  setRcvQueueNotifierKey :: s -> ConnId -> NtfPublicVerifyKey -> NtfPrivateSignKey -> m ()
+  setRcvQueueNotifierId :: s -> ConnId -> NotifierId -> m ()
+
+  -- Confirmations
+  createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
+  acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
+  getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
+  removeConfirmations :: s -> ConnId -> m ()
+  setHandshakeVersion :: s -> ConnId -> Version -> Bool -> m ()
+
+  -- Invitations - sent via Contact connections
+  createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
+  getInvitation :: s -> InvitationId -> m Invitation
+  acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()
+  deleteInvitation :: s -> ConnId -> InvitationId -> m ()
+
+  -- Msg management
+  updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
+  updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  createSndMsg :: s -> ConnId -> SndMsgData -> m ()
+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, PendingMsgData)
+  getPendingMsgs :: s -> ConnId -> m [InternalId]
+  setMsgUserAck :: s -> ConnId -> InternalId -> m MsgId
+  getLastMsg :: s -> ConnId -> SMP.MsgId -> m (Maybe RcvMsg)
+  deleteMsg :: s -> ConnId -> InternalId -> m ()
+
+  -- Double ratchet persistence
+  createRatchetX3dhKeys :: s -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
+  getRatchetX3dhKeys :: s -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
+  createRatchet :: s -> ConnId -> RatchetX448 -> m ()
+  getRatchet :: s -> ConnId -> m RatchetX448
+  getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys
+  updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
+
+  -- Notification device token persistence
+  createNtfToken :: s -> NtfToken -> m ()
+  getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
+  updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
+  updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
+  removeNtfToken :: s -> NtfToken -> m ()
+
+  -- Notification subscription persistence
+  getNtfSubscription :: s -> ConnId -> m (Maybe NtfSubscription)
+  createNtfSubscription :: s -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  markNtfSubscriptionForDeletion :: s -> ConnId -> m ()
+  updateNtfSubscription :: s -> ConnId -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  setNullNtfSubscriptionAction :: s -> ConnId -> m ()
+  deleteNtfSubscription :: s -> ConnId -> m ()
+  getNextNtfSubAction :: s -> NtfServer -> m (Maybe (NtfSubscription, NtfSubAction, RcvQueue))
+  getNextNtfSubSMPAction :: s -> SMPServer -> m (Maybe (NtfSubscription, NtfSubSMPAction, RcvQueue))
+
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
 data RcvQueue = RcvQueue
-  { connId :: ConnId,
-    server :: SMPServer,
+  { server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
     -- | key used by the recipient to sign transmissions
@@ -60,37 +122,20 @@ data RcvQueue = RcvQueue
     -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
     e2eDhSecret :: Maybe C.DhSecretX25519,
     -- | sender queue ID
-    sndId :: SMP.SenderId,
+    sndId :: Maybe SMP.SenderId,
     -- | queue status
     status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
-    dbQueueId :: Int64,
-    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
-    primary :: Bool,
-    -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
-    dbReplaceQueueId :: Maybe Int64,
-    -- | SMP client version
-    smpClientVersion :: Version,
-    -- | credentials used in context of notifications
-    clientNtfCreds :: Maybe ClientNtfCreds
-  }
-  deriving (Eq, Show)
-
-data ClientNtfCreds = ClientNtfCreds
-  { -- | key pair to be used by the notification server to sign transmissions
-    ntfPublicKey :: NtfPublicVerifyKey,
-    ntfPrivateKey :: NtfPrivateSignKey,
+    -- | key pair to be used by the notification server to sign transmissions
+    ntfPublicKey :: Maybe NtfPublicVerifyKey,
+    ntfPrivateKey :: Maybe NtfPrivateSignKey,
     -- | queue ID to be used by the notification server for NSUB command
-    notifierId :: NotifierId,
-    -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
-    rcvNtfDhSecret :: RcvNtfDhSecret
+    notifierId :: Maybe NotifierId
   }
   deriving (Eq, Show)
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
-  { connId :: ConnId,
-    server :: SMPServer,
+  { server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
     -- | key pair used by the sender to sign transmissions
@@ -101,59 +146,14 @@ data SndQueue = SndQueue
     -- | shared DH secret agreed for simple per-queue e2e encryption
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
-    status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
-    dbQueueId :: Int64,
-    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
-    primary :: Bool,
-    -- | ID of the queue this one is replacing
-    dbReplaceQueueId :: Maybe Int64,
-    -- | SMP client version
-    smpClientVersion :: Version
+    status :: QueueStatus
   }
   deriving (Eq, Show)
 
-instance SMPQueue RcvQueue where
-  qServer RcvQueue {server} = server
-  {-# INLINE qServer #-}
-  qAddress RcvQueue {server, rcvId} = (server, rcvId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
-
-instance SMPQueue SndQueue where
-  qServer SndQueue {server} = server
-  {-# INLINE qServer #-}
-  qAddress SndQueue {server, sndId} = (server, sndId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
-
-findQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe q
-findQ = find . sameQueue
-{-# INLINE findQ #-}
-
-removeQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe (q, [q])
-removeQ = removeQP . sameQueue
-{-# INLINE removeQ #-}
-
-removeQP :: (q -> Bool) -> NonEmpty q -> Maybe (q, [q])
-removeQP p qs = case L.break p qs of
-  (_, []) -> Nothing
-  (qs1, q : qs2) -> Just (q, qs1 <> qs2)
-
-sndAddress :: RcvQueue -> (SMPServer, SMP.SenderId)
-sndAddress RcvQueue {server, sndId} = (server, sndId)
-{-# INLINE sndAddress #-}
-
-findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
-findRQ sAddr = find $ sameQAddress sAddr . sndAddress
-{-# INLINE findRQ #-}
-
 -- * Connection types
 
 -- | Type of a connection.
-data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
+data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 
 -- | Connection of a specific type.
 --
@@ -166,33 +166,22 @@ data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
 data Connection (d :: ConnType) where
-  NewConnection :: ConnData -> Connection CNew
   RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
   SndConnection :: ConnData -> SndQueue -> Connection CSnd
-  DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
+  DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
   ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
 deriving instance Eq (Connection d)
 
 deriving instance Show (Connection d)
 
-connData :: Connection d -> ConnData
-connData = \case
-  NewConnection cData -> cData
-  RcvConnection cData _ -> cData
-  SndConnection cData _ -> cData
-  DuplexConnection cData _ _ -> cData
-  ContactConnection cData _ -> cData
-
 data SConnType :: ConnType -> Type where
-  SCNew :: SConnType CNew
   SCRcv :: SConnType CRcv
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
   SCContact :: SConnType CContact
 
 connType :: SConnType c -> ConnType
-connType SCNew = CNew
 connType SCRcv = CRcv
 connType SCSnd = CSnd
 connType SCDuplex = CDuplex
@@ -223,124 +212,10 @@ deriving instance Show SomeConn
 data ConnData = ConnData
   { connId :: ConnId,
     connAgentVersion :: Version,
-    enableNtfs :: Bool,
-    duplexHandshake :: Maybe Bool, -- added in agent protocol v2
-    deleted :: Bool
+    duplexHandshake :: Maybe Bool -- added in agent protocol v2
   }
   deriving (Eq, Show)
 
-data AgentCmdType = ACClient | ACInternal
-
-instance StrEncoding AgentCmdType where
-  strEncode = \case
-    ACClient -> "CLIENT"
-    ACInternal -> "INTERNAL"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "CLIENT" -> pure ACClient
-      "INTERNAL" -> pure ACInternal
-      _ -> fail "bad AgentCmdType"
-
-data AgentCommand
-  = AClientCommand (ACommand 'Client)
-  | AInternalCommand InternalCommand
-
-instance StrEncoding AgentCommand where
-  strEncode = \case
-    AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
-    AInternalCommand cmd -> strEncode (ACInternal, cmd)
-  strP =
-    strP_ >>= \case
-      ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
-      ACInternal -> AInternalCommand <$> strP
-
-data AgentCommandTag
-  = AClientCommandTag (ACommandTag 'Client)
-  | AInternalCommandTag InternalCommandTag
-  deriving (Show)
-
-instance StrEncoding AgentCommandTag where
-  strEncode = \case
-    AClientCommandTag t -> strEncode (ACClient, t)
-    AInternalCommandTag t -> strEncode (ACInternal, t)
-  strP =
-    strP_ >>= \case
-      ACClient -> AClientCommandTag <$> strP
-      ACInternal -> AInternalCommandTag <$> strP
-
-data InternalCommand
-  = ICAck SMP.RecipientId MsgId
-  | ICAckDel SMP.RecipientId MsgId InternalId
-  | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICDeleteConn
-  | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICQDelete SMP.RecipientId
-
-data InternalCommandTag
-  = ICAck_
-  | ICAckDel_
-  | ICAllowSecure_
-  | ICDuplexSecure_
-  | ICDeleteConn_
-  | ICQSecure_
-  | ICQDelete_
-  deriving (Show)
-
-instance StrEncoding InternalCommand where
-  strEncode = \case
-    ICAck rId srvMsgId -> strEncode (ICAck_, rId, srvMsgId)
-    ICAckDel rId srvMsgId mId -> strEncode (ICAckDel_, rId, srvMsgId, mId)
-    ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
-    ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
-    ICDeleteConn -> strEncode ICDeleteConn_
-    ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
-    ICQDelete rId -> strEncode (ICQDelete_, rId)
-  strP =
-    strP >>= \case
-      ICAck_ -> ICAck <$> _strP <*> _strP
-      ICAckDel_ -> ICAckDel <$> _strP <*> _strP <*> _strP
-      ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
-      ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
-      ICDeleteConn_ -> pure ICDeleteConn
-      ICQSecure_ -> ICQSecure <$> _strP <*> _strP
-      ICQDelete_ -> ICQDelete <$> _strP
-
-instance StrEncoding InternalCommandTag where
-  strEncode = \case
-    ICAck_ -> "ACK"
-    ICAckDel_ -> "ACK_DEL"
-    ICAllowSecure_ -> "ALLOW_SECURE"
-    ICDuplexSecure_ -> "DUPLEX_SECURE"
-    ICDeleteConn_ -> "DELETE_CONN"
-    ICQSecure_ -> "QSECURE"
-    ICQDelete_ -> "QDELETE"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "ACK" -> pure ICAck_
-      "ACK_DEL" -> pure ICAckDel_
-      "ALLOW_SECURE" -> pure ICAllowSecure_
-      "DUPLEX_SECURE" -> pure ICDuplexSecure_
-      "DELETE_CONN" -> pure ICDeleteConn_
-      "QSECURE" -> pure ICQSecure_
-      "QDELETE" -> pure ICQDelete_
-      _ -> fail "bad InternalCommandTag"
-
-agentCommandTag :: AgentCommand -> AgentCommandTag
-agentCommandTag = \case
-  AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
-  AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
-
-internalCmdTag :: InternalCommand -> InternalCommandTag
-internalCmdTag = \case
-  ICAck {} -> ICAck_
-  ICAckDel {} -> ICAckDel_
-  ICAllowSecure {} -> ICAllowSecure_
-  ICDuplexSecure {} -> ICDuplexSecure_
-  ICDeleteConn -> ICDeleteConn_
-  ICQSecure {} -> ICQSecure_
-  ICQDelete _ -> ICQDelete_
-
 -- * Confirmation types
 
 data NewConfirmation = NewConfirmation
@@ -455,14 +330,8 @@ data MsgBase = MsgBase
 
 newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show)
 
-instance StrEncoding InternalId where
-  strEncode = strEncode . unId
-  strP = InternalId <$> strP
-
 type InternalTs = UTCTime
 
-type AsyncCmdId = Int64
-
 -- * Store errors
 
 -- | Agent store error.
@@ -484,8 +353,6 @@ data StoreError
     SEInvitationNotFound
   | -- | Message not found
     SEMsgNotFound
-  | -- | Command not found
-    SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
     -- as we always know what it should be at any stage of the protocol,
     -- and in case it does not match use this error.
@@ -494,6 +361,8 @@ data StoreError
     SERatchetNotFound
   | -- | connection does not have associated x3dh keys
     SEX3dhKeysNotFound
+  | -- | Used in `getMsg` that is not implemented/used. TODO remove.
+    SENotImplemented
   | -- | Used to wrap agent errors inside store operations to avoid race conditions
     SEAgentError AgentErrorType
   deriving (Eq, Show, Exception)

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

@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -16,29 +15,19 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
   )
 where
 
-import Control.Monad (forM_, when)
-import Data.List (intercalate, sortOn)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map as M
+import Control.Monad (forM_)
+import Data.Function (on)
+import Data.List (intercalate, sortBy)
 import Data.Text (Text)
-import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (getCurrentTime)
 import Database.SQLite.Simple (Connection, Only (..), Query (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
-import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Transport.Client (TransportHost)
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
@@ -48,17 +37,12 @@ schemaMigrations =
   [ ("20220101_initial", m20220101_initial),
     ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
     ("20220322_notifications", m20220322_notifications),
-    ("20220607_v2", m20220608_v2),
-    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
-    ("m20220811_onion_hosts", m20220811_onion_hosts),
-    ("m20220817_connection_ntfs", m20220817_connection_ntfs),
-    ("m20220905_commands", m20220905_commands),
-    ("m20220915_connection_queues", m20220915_connection_queues)
+    ("20220607_v2", m20220608_v2)
   ]
 
 -- | The list of migrations in ascending order by date
 app :: [Migration]
-app = sortOn name $ map migration schemaMigrations
+app = sortBy (compare `on` name) $ map migration schemaMigrations
   where
     migration (name, query) = Migration {name = name, up = fromQuery query}
 
@@ -68,16 +52,11 @@ get conn migrations =
     <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
 
 run :: Connection -> [Migration] -> IO ()
-run conn ms = forM_ ms $ \Migration {name, up} -> do
-  when (name == "m20220811_onion_hosts") updateServers
-  DB.withImmediateTransaction conn $ insert name >> execSQL up
+run conn ms = DB.withImmediateTransaction conn . forM_ ms $
+  \Migration {name, up} -> insert name >> execSQL up
   where
     insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
     execSQL = SQLite3.exec $ DB.connectionHandle conn
-    updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
-      DB.withImmediateTransaction conn $
-        let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
-         in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
 
 initialize :: Connection -> IO ()
 initialize conn =

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

@@ -107,8 +107,8 @@ CREATE TABLE snd_messages (
 CREATE TABLE conn_confirmations (
   confirmation_id BLOB NOT NULL PRIMARY KEY,
   conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  e2e_snd_pub_key BLOB NOT NULL,
-  sender_key BLOB NOT NULL,
+  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
+  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
   ratchet_state BLOB NOT NULL,
   sender_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL,

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

@@ -18,7 +18,7 @@ CREATE TABLE ntf_servers (
 ) WITHOUT ROWID;
 
 CREATE TABLE ntf_tokens (
-  provider TEXT NOT NULL, -- apns
+  provider TEXT NOT NULL, -- apn
   device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
   ntf_host TEXT NOT NULL,
   ntf_port TEXT NOT NULL,

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

@@ -22,12 +22,10 @@ ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
 
 ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
 
-ALTER TABLE rcv_queues ADD COLUMN rcv_ntf_dh_secret BLOB;
-
 CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
 
 CREATE TABLE ntf_subscriptions (
-  conn_id BLOB NOT NULL,
+  conn_id BLOB NOT NULL, -- ? make nullable for when connection is deleted but we still need to delete subscription
   smp_host TEXT NULL,
   smp_port TEXT NULL,
   smp_ntf_id BLOB,
@@ -35,13 +33,15 @@ CREATE TABLE ntf_subscriptions (
   ntf_port TEXT NOT NULL,
   ntf_sub_id BLOB,
   ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubAction
   ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can (should) be not null in same record
   ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
   updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command (state still should be updated)
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
   updated_at TEXT NOT NULL DEFAULT (datetime('now')),
   PRIMARY KEY (conn_id),
+  -- FOREIGN KEY (conn_id) REFERENCES connections
+  --   ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY (smp_host, smp_port) REFERENCES servers (host, port)
     ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers

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

@@ -1,14 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220625_v2_ntf_mode :: Query
-m20220625_v2_ntf_mode =
-  [sql|
-ALTER TABLE ntf_tokens ADD COLUMN ntf_mode TEXT NULL;
-
-DELETE FROM ntf_tokens;
-|]

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

@@ -1,16 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220811_onion_hosts :: Query
-m20220811_onion_hosts =
-  [sql|
-ALTER TABLE conn_confirmations ADD COLUMN smp_client_version INTEGER;
-
-UPDATE ntf_servers
-SET ntf_host = 'ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion'
-WHERE ntf_host = 'ntf2.simplex.im';
-|]

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

@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220817_connection_ntfs :: Query
-m20220817_connection_ntfs =
-  [sql|
-ALTER TABLE connections ADD COLUMN enable_ntfs INTEGER;
-|]

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

@@ -1,23 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220905_commands :: Query
-m20220905_commands =
-  [sql|
-CREATE TABLE commands (
-  command_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  host TEXT,
-  port TEXT,
-  corr_id BLOB NOT NULL,
-  command_tag BLOB NOT NULL,
-  command BLOB NOT NULL,
-  agent_version INTEGER NOT NULL DEFAULT 1,
-  FOREIGN KEY (host, port) REFERENCES servers
-    ON DELETE RESTRICT ON UPDATE CASCADE
-);
-|]

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

@@ -1,52 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220915_connection_queues :: Query
-m20220915_connection_queues =
-  [sql|
-PRAGMA ignore_check_constraints=ON;
-
--- rcv_queues
-ALTER TABLE rcv_queues ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
-UPDATE rcv_queues SET rcv_queue_id = 1;
-CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues (conn_id, rcv_queue_id);
-
-ALTER TABLE rcv_queues ADD COLUMN rcv_primary INTEGER CHECK (rcv_primary NOT NULL);
-UPDATE rcv_queues SET rcv_primary = 1;
-
-ALTER TABLE rcv_queues ADD COLUMN replace_rcv_queue_id INTEGER NULL;
-
--- snd_queues
-ALTER TABLE snd_queues ADD COLUMN snd_queue_id INTEGER CHECK (snd_queue_id NOT NULL);
-UPDATE snd_queues SET snd_queue_id = 1;
-CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues (conn_id, snd_queue_id);
-
-ALTER TABLE snd_queues ADD COLUMN snd_primary INTEGER CHECK (snd_primary NOT NULL);
-UPDATE snd_queues SET snd_primary = 1;
-
-ALTER TABLE snd_queues ADD COLUMN replace_snd_queue_id INTEGER NULL;
-
--- connections
-ALTER TABLE connections ADD COLUMN deleted INTEGER DEFAULT 0 CHECK (deleted NOT NULL);
-UPDATE connections SET deleted = 0;
-
--- messages
-CREATE TABLE snd_message_deliveries (
-  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_queue_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  FOREIGN KEY (conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-);
-
-CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries (conn_id, snd_queue_id);
-
-ALTER TABLE rcv_messages ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
-UPDATE rcv_messages SET rcv_queue_id = 1;
-
-PRAGMA ignore_check_constraints=OFF;
-|]

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

@@ -20,9 +20,7 @@ CREATE TABLE connections(
   last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
   smp_agent_version INTEGER NOT NULL DEFAULT 1
   ,
-  duplex_handshake INTEGER NULL DEFAULT 0,
-  enable_ntfs INTEGER,
-  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
+  duplex_handshake INTEGER NULL DEFAULT 0
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -41,10 +39,6 @@ CREATE TABLE rcv_queues(
   ntf_public_key BLOB,
   ntf_private_key BLOB,
   ntf_id BLOB,
-  rcv_ntf_dh_secret BLOB,
-  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
-  rcv_primary INTEGER CHECK(rcv_primary NOT NULL),
-  replace_rcv_queue_id INTEGER NULL,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -62,9 +56,6 @@ CREATE TABLE snd_queues(
   smp_client_version INTEGER NOT NULL DEFAULT 1,
   snd_public_key BLOB,
   e2e_pub_key BLOB,
-  snd_queue_id INTEGER CHECK(snd_queue_id NOT NULL),
-  snd_primary INTEGER CHECK(snd_primary NOT NULL),
-  replace_snd_queue_id INTEGER NULL,
   PRIMARY KEY(host, port, snd_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
@@ -96,7 +87,6 @@ CREATE TABLE rcv_messages(
   external_prev_snd_hash BLOB NOT NULL,
   integrity BLOB NOT NULL,
   user_ack INTEGER NULL DEFAULT 0,
-  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
   PRIMARY KEY(conn_id, internal_rcv_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -114,16 +104,15 @@ CREATE TABLE snd_messages(
 CREATE TABLE conn_confirmations(
   confirmation_id BLOB NOT NULL PRIMARY KEY,
   conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  e2e_snd_pub_key BLOB NOT NULL,
-  sender_key BLOB NOT NULL,
+  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
+  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
   ratchet_state BLOB NOT NULL,
   sender_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL,
   own_conn_info BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now'))
   ,
-  smp_reply_queues BLOB NULL,
-  smp_client_version INTEGER
+  smp_reply_queues BLOB NULL
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
@@ -161,7 +150,7 @@ CREATE TABLE ntf_servers(
   PRIMARY KEY(ntf_host, ntf_port)
 ) WITHOUT ROWID;
 CREATE TABLE ntf_tokens(
-  provider TEXT NOT NULL, -- apns
+  provider TEXT NOT NULL, -- apn
   device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
   ntf_host TEXT NOT NULL,
   ntf_port TEXT NOT NULL,
@@ -174,15 +163,14 @@ tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
   tkn_status TEXT NOT NULL,
   tkn_action BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
-  ntf_mode TEXT NULL, -- this is to check token status periodically to know when it was last checked
+  updated_at TEXT NOT NULL DEFAULT(datetime('now')), -- this is to check token status periodically to know when it was last checked
   PRIMARY KEY(provider, device_token, ntf_host, ntf_port),
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
 CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
 CREATE TABLE ntf_subscriptions(
-  conn_id BLOB NOT NULL,
+  conn_id BLOB NOT NULL, -- ? make nullable for when connection is deleted but we still need to delete subscription
   smp_host TEXT NULL,
   smp_port TEXT NULL,
   smp_ntf_id BLOB,
@@ -190,41 +178,17 @@ CREATE TABLE ntf_subscriptions(
   ntf_port TEXT NOT NULL,
   ntf_sub_id BLOB,
   ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubAction
   ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can(should) be not null in same record
   ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
   updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
   PRIMARY KEY(conn_id),
+  -- FOREIGN KEY(conn_id) REFERENCES connections
+  -- ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
   ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
-CREATE TABLE commands(
-  command_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  host TEXT,
-  port TEXT,
-  corr_id BLOB NOT NULL,
-  command_tag BLOB NOT NULL,
-  command BLOB NOT NULL,
-  agent_version INTEGER NOT NULL DEFAULT 1,
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE
-);
-CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
-CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
-CREATE TABLE snd_message_deliveries(
-  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_queue_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-);
-CREATE TABLE sqlite_sequence(name,seq);
-CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
-  conn_id,
-  snd_queue_id
-);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Agent.TRcvQueues where
-
-import Control.Concurrent.STM
-import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import qualified Data.Set as S
-import Simplex.Messaging.Agent.Protocol (ConnId)
-import Simplex.Messaging.Agent.Store (RcvQueue (..))
-import Simplex.Messaging.Protocol (RecipientId, SMPServer)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-
-newtype TRcvQueues = TRcvQueues (TMap (SMPServer, RecipientId) RcvQueue)
-
-empty :: STM TRcvQueues
-empty = TRcvQueues <$> TM.empty
-
-clear :: TRcvQueues -> STM ()
-clear (TRcvQueues qs) = TM.clear qs
-
-deleteConn :: ConnId -> TRcvQueues -> STM ()
-deleteConn cId (TRcvQueues qs) = modifyTVar' qs $ M.filter (\rq -> cId /= connId rq)
-
-hasConn :: ConnId -> TRcvQueues -> STM Bool
-hasConn cId (TRcvQueues qs) = any (\rq -> cId == connId rq) <$> readTVar qs
-
-getConns :: TRcvQueues -> STM (Set ConnId)
-getConns (TRcvQueues qs) = M.foldr' (S.insert . connId) S.empty <$> readTVar qs
-
-addQueue :: RcvQueue -> TRcvQueues -> STM ()
-addQueue rq@RcvQueue {server, rcvId} (TRcvQueues qs) = TM.insert (server, rcvId) rq qs
-
-deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
-deleteQueue RcvQueue {server, rcvId} (TRcvQueues qs) = TM.delete (server, rcvId) qs
-
-getSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
-getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
-  where
-    addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs'
-
-getDelSrvQueues :: SMPServer -> TRcvQueues -> STM ([RcvQueue], Set ConnId)
-getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty)
-  where
-    addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId, server, rcvId}
-      | srv == server = ((rq : remQs, S.insert connId remConns), qs')
-      | otherwise = (removed, M.insert (server, rcvId) rq qs')

src/Simplex/Messaging/Client.hs

@@ -1,13 +1,11 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,24 +24,18 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    ProtocolClient (thVersion, sessionId, sessionTs),
+    ProtocolClient (sessionId),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
-    clientServer,
-    transportHost',
 
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
-    subscribeSMPQueues,
     getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
-    disableSMPQueueNotifications,
-    enableSMPQueuesNtfs,
-    disableSMPQueuesNtfs,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
@@ -53,11 +45,7 @@ module Simplex.Messaging.Client
     -- * Supporting types and client configuration
     ProtocolClientError (..),
     ProtocolClientConfig (..),
-    NetworkConfig (..),
     defaultClientConfig,
-    defaultNetworkConfig,
-    transportClientConfig,
-    chooseTransportHost,
     ServerTransmission,
   )
 where
@@ -67,33 +55,22 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (rights)
-import Data.Functor (($>))
-import Data.List (find)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import GHC.Generics (Generic)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
 import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
+import Simplex.Messaging.Transport.Client (runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (bshow, raceAny_)
+import Simplex.Messaging.Util (bshow, liftError, raceAny_)
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
 
@@ -101,89 +78,23 @@ import System.Timeout (timeout)
 --
 -- Use 'getSMPClient' to connect to an SMP server and create a client handle.
 data ProtocolClient msg = ProtocolClient
-  { action :: Maybe (Async ()),
+  { action :: Async (),
+    connected :: TVar Bool,
     sessionId :: SessionId,
-    sessionTs :: UTCTime,
     thVersion :: Version,
-    client_ :: PClient msg
-  }
-
-data PClient msg = PClient
-  { connected :: TVar Bool,
-    protocolServer :: ProtoServer msg,
-    transportHost :: TransportHost,
+    protocolServer :: ProtocolServer,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request msg),
-    sndQ :: TBQueue (NonEmpty SentRawTransmission),
-    rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
+    sndQ :: TBQueue SentRawTransmission,
+    rcvQ :: TBQueue (SignedTransmission msg),
     msgQ :: Maybe (TBQueue (ServerTransmission msg))
   }
 
 type SMPClient = ProtocolClient SMP.BrokerMsg
 
--- | Type for client command data
-type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
-
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
-
-data HostMode
-  = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
-    HMOnionViaSocks
-  | -- | prefer (or require) onion hosts
-    HMOnion
-  | -- | prefer (or require) public hosts
-    HMPublic
-  deriving (Eq, Show, Generic)
-
-instance FromJSON HostMode where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
-
-instance ToJSON HostMode where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
-
--- | network configuration for the client
-data NetworkConfig = NetworkConfig
-  { -- | use SOCKS5 proxy
-    socksProxy :: Maybe SocksProxy,
-    -- | determines critera which host is chosen from the list
-    hostMode :: HostMode,
-    -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
-    requiredHostMode :: Bool,
-    -- | timeout for the initial client TCP/TLS connection (microseconds)
-    tcpConnectTimeout :: Int,
-    -- | timeout of protocol commands (microseconds)
-    tcpTimeout :: Int,
-    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    -- | period for SMP ping commands (microseconds)
-    smpPingInterval :: Int,
-    logTLSErrors :: Bool
-  }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON NetworkConfig where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-defaultNetworkConfig :: NetworkConfig
-defaultNetworkConfig =
-  NetworkConfig
-    { socksProxy = Nothing,
-      hostMode = HMOnionViaSocks,
-      requiredHostMode = False,
-      tcpConnectTimeout = 7_500_000,
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPingInterval = 600_000_000, -- 10min
-      logTLSErrors = False
-    }
-
-transportClientConfig :: NetworkConfig -> TransportClientConfig
-transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
-  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
+type ServerTransmission msg = (ProtocolServer, SessionId, QueueId, msg)
 
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
@@ -191,8 +102,12 @@ data ProtocolClientConfig = ProtocolClientConfig
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
     defaultTransport :: (ServiceName, ATransport),
-    -- | network configuration
-    networkConfig :: NetworkConfig,
+    -- | timeout of TCP commands (microseconds)
+    tcpTimeout :: Int,
+    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    -- | period for SMP ping commands (microseconds)
+    smpPing :: Int,
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange
   }
@@ -203,7 +118,9 @@ defaultClientConfig =
   ProtocolClientConfig
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
-      networkConfig = defaultNetworkConfig,
+      tcpTimeout = 5_000_000,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      smpPing = 600_000_000, -- 10min
       smpServerVRange = supportedSMPServerVRange
     }
 
@@ -214,52 +131,30 @@ data Request msg = Request
 
 type Response msg = Either ProtocolClientError msg
 
-chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
-chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
-  firstOrError $ case hostMode of
-    HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
-    HMOnion -> onionHost
-    HMPublic -> publicHost
-  where
-    firstOrError
-      | requiredHostMode = maybe (Left PCEIncompatibleHost) Right
-      | otherwise = Right . fromMaybe (L.head hosts)
-    isOnionHost = \case THOnionHost _ -> True; _ -> False
-    onionHost = find isOnionHost hosts
-    publicHost = find (not . isOnionHost) hosts
-
-clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient msg -> String
-clientServer = B.unpack . strEncode . protocolServer . client_
-
-transportHost' :: ProtocolClient msg -> TransportHost
-transportHost' = transportHost . client_
-
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
-  case chooseTransportHost networkConfig (host protocolServer) of
-    Right useHost ->
-      (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
-        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
-    Left e -> pure $ Left e
+getProtocolClient :: forall msg. Protocol msg => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
+  (atomically mkProtocolClient >>= runClient useTransport)
+    `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
   where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> STM (PClient msg)
-    mkProtocolClient transportHost = do
+    mkProtocolClient :: STM (ProtocolClient msg)
+    mkProtocolClient = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
       sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        PClient
-          { connected,
+        ProtocolClient
+          { action = undefined,
+            sessionId = undefined,
+            thVersion = undefined,
+            connected,
             protocolServer,
-            transportHost,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -268,17 +163,16 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
-    runClient (port', ATransport t) useHost c = do
-      cVar <- newEmptyTMVarIO
-      let tcConfig = transportClientConfig networkConfig
+    runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient (port', ATransport t) c = do
+      thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient tcConfig useHost port' (Just $ keyHash protocolServer) (client t c cVar)
-            `finally` atomically (putTMVar cVar $ Left PCENetworkError)
-      c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
-      pure $ case c_ of
-        Just (Right c') -> Right c' {action = Just action}
+          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
+            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
+      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
+      pure $ case th_ of
+        Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
         Just (Left e) -> Left e
         Nothing -> Left PCENetworkError
 
@@ -288,40 +182,38 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> PClient msg -> TMVar (Either ProtocolClientError (ProtocolClient msg)) -> c -> IO ()
-    client _ c cVar h =
+    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
+    client _ c thVar h =
       runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
-        Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
+        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
         Right th@THandle {sessionId, thVersion} -> do
-          sessionTs <- getCurrentTime
-          let c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs}
           atomically $ do
             writeTVar (connected c) True
-            putTMVar cVar $ Right c'
-          raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
-            `finally` disconnected c'
+            putTMVar thVar $ Right th
+          let c' = c {sessionId, thVersion} :: ProtocolClient msg
+          -- TODO remove ping if 0 is passed (or Nothing?)
+          raceAny_ [send c' th, process c', receive c' th, ping c']
+            `finally` disconnected
 
     send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
     receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
+    receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
     ping :: ProtocolClient msg -> IO ()
     ping c = forever $ do
-      threadDelay smpPingInterval
+      threadDelay smpPing
       runExceptT $ sendProtocolCommand c Nothing "" protocolPing
 
     process :: ProtocolClient msg -> IO ()
-    process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
-
-    processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
-    processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, qId, respOrErr)) =
+    process ProtocolClient {sessionId, rcvQ, sentCommands} = forever $ do
+      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
       if B.null $ bs corrId
-        then sendMsg respOrErr
+        then sendMsg qId respOrErr
         else do
           atomically (TM.lookup corrId sentCommands) >>= \case
-            Nothing -> sendMsg respOrErr
+            Nothing -> sendMsg qId respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
               TM.delete corrId sentCommands
               putTMVar responseVar $
@@ -331,16 +223,17 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
                     Right r -> case protocolError r of
                       Just e -> Left $ PCEProtocolError e
                       _ -> Right r
-                  else Left . PCEUnexpectedResponse $ bshow respOrErr
+                  else Left PCEUnexpectedResponse
       where
-        sendMsg :: Either ErrorType msg -> IO ()
-        sendMsg = \case
-          Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
-          Left e -> putStrLn $ "SMP client error: " <> show e
+        sendMsg :: QueueId -> Either ErrorType msg -> IO ()
+        sendMsg qId = \case
+          Right cmd -> atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, qId, cmd)) msgQ
+          -- TODO send everything else to errQ and log in agent
+          _ -> return ()
 
 -- | Disconnects client from the server and terminates client threads.
 closeProtocolClient :: ProtocolClient msg -> IO ()
-closeProtocolClient = mapM_ uninterruptibleCancel . action
+closeProtocolClient = uninterruptibleCancel . action
 
 -- | SMP client error type.
 data ProtocolClientError
@@ -354,15 +247,13 @@ data ProtocolClientError
     -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
     -- other responses would result in this error.
     -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
-    PCEUnexpectedResponse ByteString
+    PCEUnexpectedResponse
   | -- | Used for TCP connection and command response timeouts.
     -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
     PCEResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
     PCENetworkError
-  | -- | No host compatible with network configuration
-    PCEIncompatibleHost
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
@@ -380,50 +271,34 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
-  Maybe BasicAuth ->
   ExceptT ProtocolClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey auth =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
+createSMPQueue c rpKey rKey dhKey =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
     IDS qik -> pure qik
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
 subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
-subscribeSMPQueue c rpKey rId =
+subscribeSMPQueue c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
-    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
--- | Subscribe to multiple SMP queues batching commands if supported.
-subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
-subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
-  where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
-    response ((_, rId), r) = case r of
-      Right OK -> pure $ Right ()
-      Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
-      Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
-      Left e -> pure $ Left e
-
-writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
-writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
-
-serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
-serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {protocolServer}} entityId message =
-  (protocolServer, thVersion, sessionId, entityId, message)
+    cmd@MSG {} ->
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
 --
 -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
-getSMPMessage c rpKey rId =
+getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe (MsgId, MsgFlags))
+getSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
-    cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    cmd@(MSG msgId _ msgFlags _) -> do
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+      pure $ Just (msgId, msgFlags)
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Subscribe to the SMP queue notifications.
 --
@@ -440,37 +315,11 @@ secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
-enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
-enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
-  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
-    NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
--- | Enable notifications for the multiple queues for push notifications server.
-enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
-enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
-  where
-    cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
-    response = \case
-      Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
-      Right r -> Left . PCEUnexpectedResponse $ bshow r
-      Left e -> Left e
-
--- | Disable notifications for the queue for push notifications server.
---
--- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
-disableSMPQueueNotifications = okSMPCommand NDEL
-
--- | Disable notifications for multiple queues for push notifications server.
-disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
-disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
-  where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
-    response = \case
-      Right OK -> Right ()
-      Right r -> Left . PCEUnexpectedResponse $ bshow r
-      Left e -> Left e
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT ProtocolClientError IO NotifierId
+enableSMPQueueNotifications c rpKey rId notifierKey =
+  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
+    NID nId -> pure nId
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Send SMP message.
 --
@@ -479,17 +328,18 @@ sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -
 sendSMPMessage c spKey sId flags msg =
   sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
 ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
-ackSMPMessage c rpKey rId msgId =
+ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId msgId =
   sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
-    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    cmd@MSG {} ->
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Irreversibly suspend SMP queue.
 -- The existing messages from the queue will still be delivered.
@@ -508,50 +358,43 @@ okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> Queue
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Send SMP command
 sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
 sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
--- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
-sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} cs = do
-  ts <- mapM (runExceptT . mkTransmission c) cs
-  mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
-  forConcurrently ts $ \case
-    Right (_, r) -> withTimeout . atomically $ takeTMVar r
-    Left e -> pure $ Left e
-  where
-    withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
-
 -- | Send Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey qId cmd = do
-  (t, r) <- mkTransmission c (pKey, qId, cmd)
-  ExceptT $ sendRecv t r
+sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
+sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
+  corrId <- lift_ getNextCorrId
+  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
+  ExceptT $ sendRecv corrId t
   where
-    -- two separate "atomically" needed to avoid blocking
-    sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
-    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
-      where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
+    lift_ :: STM a -> ExceptT ProtocolClientError IO a
+    lift_ action = ExceptT $ Right <$> atomically action
 
-mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
-mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do
-  corrId <- liftIO $ atomically getNextCorrId
-  let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
-  r <- liftIO . atomically $ mkRequest corrId
-  pure (t, r)
-  where
     getNextCorrId :: STM CorrId
     getNextCorrId = do
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
-    signTransmission :: ByteString -> SentRawTransmission
-    signTransmission t = ((`C.sign` t) <$> pKey, t)
-    mkRequest :: CorrId -> STM (TMVar (Response msg))
-    mkRequest corrId = do
+
+    signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
+    signTransmission t = case pKey of
+      Nothing -> return (Nothing, t)
+      Just pk -> do
+        sig <- liftError PCESignatureError $ C.sign pk t
+        return (Just sig, t)
+
+    -- two separate "atomically" needed to avoid blocking
+    sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
+    sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
+      where
+        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
+
+    send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
+    send corrId t = do
       r <- newEmptyTMVar
       TM.insert corrId (Request qId r) sentCommands
-      pure r
+      writeTBQueue sndQ t
+      return r

src/Simplex/Messaging/Client/Agent.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Client.Agent where
@@ -26,12 +25,10 @@ import Numeric.Natural
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
+import Simplex.Messaging.Util (catchAll_, tryE, whenM, ($>>=))
 import System.Timeout (timeout)
 import UnliftIO (async, forConcurrently_)
 import UnliftIO.Exception (Exception)
@@ -48,7 +45,7 @@ data SMPClientAgentEvent
   | CASubError SMPServer SMPSub ProtocolClientError
 
 data SMPSubParty = SPRecipient | SPNotifier
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord)
 
 type SMPSub = (SMPSubParty, QueueId)
 
@@ -64,7 +61,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
 defaultSMPClientAgentConfig :: SMPClientAgentConfig
 defaultSMPClientAgentConfig =
   SMPClientAgentConfig
-    { smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+    { smpCfg = defaultClientConfig,
       reconnectInterval =
         RetryInterval
           { initialInterval = second,
@@ -126,8 +123,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
 
     waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
     waitForSMPClient smpVar = do
-      let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
+      let ProtocolClientConfig {tcpTimeout} = smpCfg agentCfg
+      smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
       liftEither $ case smpClient_ of
         Just (Right smpClient) -> Right smpClient
         Just (Left e) -> Left e
@@ -162,8 +159,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
     connectClient :: ExceptT ProtocolClientError IO SMPClient
     connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
-    clientDisconnected :: SMPClient -> IO ()
-    clientDisconnected _ = do
+    clientDisconnected :: IO ()
+    clientDisconnected = do
       removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
@@ -204,7 +201,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
         notify $ CAReconnected srv
         cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
         forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          unlessM (atomically $ hasSub (srvSubs ca) srv s) $
+          whenM (atomically $ hasSub (srvSubs ca) srv s) $
             subscribe_ smp sub `catchE` handleError s
       where
         subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
@@ -265,7 +262,7 @@ subscribeQueue ca srv sub = do
 
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
-  strEncode host <> B.pack (if null port then "" else ':' : port)
+  B.pack $ host <> if null port then "" else ':' : port
 
 smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
 smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId

src/Simplex/Messaging/Crypto.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -67,9 +66,7 @@ module Simplex.Messaging.Crypto
 
     -- * key encoding/decoding
     encodePubKey,
-    decodePubKey,
     encodePrivKey,
-    decodePrivKey,
     pubKeyBytes,
 
     -- * sign/verify
@@ -104,7 +101,6 @@ module Simplex.Messaging.Crypto
     -- * NaCl crypto_box
     CbNonce (unCbNonce),
     cbEncrypt,
-    cbEncryptMaxLenBS,
     cbDecrypt,
     cbNonce,
     randomCbNonce,
@@ -122,13 +118,6 @@ module Simplex.Messaging.Crypto
 
     -- * Cryptography error type
     CryptoError (..),
-
-    -- * Limited size ByteStrings
-    MaxLenBS,
-    pattern MaxLenBS,
-    maxLenBS,
-    unsafeMaxLenBS,
-    appendMaxLenBS,
   )
 where
 
@@ -164,11 +153,11 @@ import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
 import Data.String
 import Data.Type.Equality
-import Data.Typeable (Proxy (Proxy), Typeable)
+import Data.Typeable (Typeable)
 import Data.X509
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
+import GHC.TypeLits (ErrorMessage (..), TypeError)
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -261,12 +250,6 @@ deriving instance Eq (PrivateKey a)
 
 deriving instance Show (PrivateKey a)
 
-instance StrEncoding (PrivateKey X25519) where
-  strEncode = strEncode . encodePrivKey
-  {-# INLINE strEncode #-}
-  strDecode = decodePrivKey
-  {-# INLINE strDecode #-}
-
 data APrivateKey
   = forall a.
     AlgorithmI a =>
@@ -313,12 +296,6 @@ instance Encoding APrivateSignKey where
   smpDecode = decodePrivKey
   {-# INLINE smpDecode #-}
 
-instance StrEncoding APrivateSignKey where
-  strEncode = strEncode . encodePrivKey
-  {-# INLINE strEncode #-}
-  strDecode = decodePrivKey
-  {-# INLINE strDecode #-}
-
 data APublicVerifyKey
   = forall a.
     (AlgorithmI a, SignatureAlgorithm a) =>
@@ -693,8 +670,6 @@ data CryptoError
   | -- | message is larger that allowed padded length minus 2 (to prepend message length)
     -- (or required un-padded length is larger than the message length)
     CryptoLargeMsgError
-  | -- | padded message is shorter than 2 bytes
-    CryptoInvalidMsgError
   | -- | failure parsing message header
     CryptoHeaderError String
   | -- | no sending chain key in ratchet state
@@ -806,12 +781,9 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
   aead <- initAEAD @AES256 aesKey ivBytes
   liftEither . unPad =<< maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg authTag)
 
-maxMsgLen :: Int
-maxMsgLen = 2 ^ (16 :: Int) - 3
-
 pad :: ByteString -> Int -> Either CryptoError ByteString
 pad msg paddedLen
-  | len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
+  | padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
   | otherwise = Left CryptoLargeMsgError
   where
     len = B.length msg
@@ -819,47 +791,12 @@ pad msg paddedLen
 
 unPad :: ByteString -> Either CryptoError ByteString
 unPad padded
-  | B.length lenWrd == 2 && B.length rest >= len = Right $ B.take len rest
-  | otherwise = Left CryptoInvalidMsgError
+  | B.length rest >= len = Right $ B.take len rest
+  | otherwise = Left CryptoLargeMsgError
   where
     (lenWrd, rest) = B.splitAt 2 padded
     len = fromIntegral $ decodeWord16 lenWrd
 
-newtype MaxLenBS (i :: Nat) = MLBS {unMaxLenBS :: ByteString}
-
-pattern MaxLenBS :: ByteString -> MaxLenBS i
-pattern MaxLenBS s <- MLBS s
-
-{-# COMPLETE MaxLenBS #-}
-
-instance KnownNat i => Encoding (MaxLenBS i) where
-  smpEncode (MLBS s) = smpEncode s
-  smpP = first show . maxLenBS <$?> smpP
-
-instance KnownNat i => StrEncoding (MaxLenBS i) where
-  strEncode (MLBS s) = strEncode s
-  strP = first show . maxLenBS <$?> strP
-
-maxLenBS :: forall i. KnownNat i => ByteString -> Either CryptoError (MaxLenBS i)
-maxLenBS s
-  | B.length s > maxLength @i = Left CryptoLargeMsgError
-  | otherwise = Right $ MLBS s
-
-unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
-unsafeMaxLenBS = MLBS
-
-padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
-padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
-  where
-    len = B.length msg
-    padLen = maxLength @i - len
-
-appendMaxLenBS :: (KnownNat i, KnownNat j) => MaxLenBS i -> MaxLenBS j -> MaxLenBS (i + j)
-appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
-
-maxLength :: forall i. KnownNat i => Int
-maxLength = fromIntegral (natVal $ Proxy @i)
-
 initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEAD (Key aesKey) (IV ivBytes) = do
   iv <- makeIV @c ivBytes
@@ -890,12 +827,12 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
 -- | Message signing.
 --
 -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages.
-sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
-sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
-sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
+sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a)
+sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg
+sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg
 
-sign :: APrivateSignKey -> ByteString -> ASignature
-sign (APrivateSignKey a k) = ASignature a . sign' k
+sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature
+sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k
 
 -- | Signature verification.
 --
@@ -915,17 +852,12 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 
 -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
 cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
-cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
-
--- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
-cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
-cbEncryptMaxLenBS secret (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
-
-cryptoBox :: DhSecret 'X25519 -> ByteString -> ByteString -> ByteString
-cryptoBox secret nonce s = BA.convert tag <> c
+cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox <$> pad msg paddedLen
   where
-    (rs, c) = xSalsa20 secret nonce s
-    tag = Poly1305.auth rs c
+    cryptoBox s = BA.convert tag <> c
+      where
+        (rs, c) = xSalsa20 secret nonce s
+        tag = Poly1305.auth rs c
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
@@ -939,7 +871,7 @@ cbDecrypt secret (CbNonce nonce) packet
     tag = Poly1305.auth rs c
 
 newtype CbNonce = CbNonce {unCbNonce :: ByteString}
-  deriving (Eq, Show)
+  deriving (Show)
 
 instance StrEncoding CbNonce where
   strEncode (CbNonce s) = strEncode s
@@ -964,7 +896,11 @@ pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
 pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar
 
 pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
-pseudoRandomBytes n gVar = stateTVar gVar $ randomBytesGenerate n
+pseudoRandomBytes n gVar = do
+  g <- readTVar gVar
+  let (bytes, g') = randomBytesGenerate n g
+  writeTVar gVar g'
+  return bytes
 
 instance Encoding CbNonce where
   smpEncode = unCbNonce

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -41,11 +41,11 @@ import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')
 import Simplex.Messaging.Util (tryE)
 import Simplex.Messaging.Version
 
-currentE2EEncryptVersion :: Version
-currentE2EEncryptVersion = 2
+e2eEncryptVersion :: Version
+e2eEncryptVersion = 1
 
-supportedE2EEncryptVRange :: VersionRange
-supportedE2EEncryptVRange = mkVersionRange 1 currentE2EEncryptVersion
+e2eEncryptVRange :: VersionRange
+e2eEncryptVRange = mkVersionRange 1 e2eEncryptVersion
 
 data E2ERatchetParams (a :: Algorithm)
   = E2ERatchetParams Version (PublicKey a) (PublicKey a)
@@ -96,27 +96,20 @@ data RatchetInitParams = RatchetInitParams
   deriving (Eq, Show)
 
 x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhSnd spk1 spk2 (E2ERatchetParams v rk1 rk2) =
-  x3dh v (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
+x3dhSnd spk1 spk2 (E2ERatchetParams _ rk1 rk2) =
+  x3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
 
 x3dhRcv :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhRcv rpk1 rpk2 (E2ERatchetParams v sk1 sk2) =
-  x3dh v (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
+x3dhRcv rpk1 rpk2 (E2ERatchetParams _ sk1 sk2) =
+  x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
 
-x3dh :: DhAlgorithm a => Version -> (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
-x3dh v (sk1, rk1) dh1 dh2 dh3 =
+x3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
+x3dh (sk1, rk1) dh1 dh2 dh3 =
   RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk}
   where
     assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
-    dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
-    (hk, nhk, sk)
-      -- for backwards compatibility with clients using agent version before 3.4.0
-      | v == 1 =
-        let (hk', rest) = B.splitAt 32 dhs
-         in uncurry (hk',,) $ B.splitAt 32 rest
-      | otherwise =
-        let salt = B.replicate 64 '\0'
-         in hkdf3 salt dhs "SimpleXX3DH"
+    (hk, rest) = B.splitAt 32 $ dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
+    (nhk, sk) = B.splitAt 32 rest
 
 type RatchetX448 = Ratchet 'X448
 
@@ -217,12 +210,12 @@ instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
 -- Please note that sPKey is not stored, and its public part together with random salt
 -- is sent to the recipient.
 initSndRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
-initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
+  forall a. (AlgorithmI a, DhAlgorithm a) => PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
+initSndRatchet rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))
   let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs
    in Ratchet
-        { rcVersion,
+        { rcVersion = e2eEncryptVRange,
           rcAD = assocData,
           rcDHRs,
           rcRK,
@@ -240,10 +233,10 @@ initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey,
 -- Please note that the public part of rcDHRs was sent to the sender
 -- as part of the connection request and random salt was received from the sender.
 initRcvRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PrivateKey a -> RatchetInitParams -> Ratchet a
-initRcvRatchet rcVersion rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
+  forall a. (AlgorithmI a, DhAlgorithm a) => PrivateKey a -> RatchetInitParams -> Ratchet a
+initRcvRatchet rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
   Ratchet
-    { rcVersion,
+    { rcVersion = e2eEncryptVRange,
       rcAD = assocData,
       rcDHRs,
       rcRK = ratchetKey,
@@ -472,6 +465,7 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
     decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
     decryptMessage (MessageKey mk iv) EncRatchetMessage {emHeader, emBody, emAuthTag} =
       -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
+      -- TODO add associated data
       tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
 
 rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> (RatchetKey, RatchetKey, Key)

src/Simplex/Messaging/Encoding.hs

@@ -13,7 +13,6 @@ module Simplex.Messaging.Encoding
     Large (..),
     smpEncodeList,
     smpListP,
-    lenEncode,
   )
 where
 
@@ -198,9 +197,3 @@ instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f
   {-# INLINE smpEncode #-}
   smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
-
-instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
-  smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
-  {-# INLINE smpEncode #-}
-  smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}

src/Simplex/Messaging/Encoding/String.hs

@@ -6,7 +6,6 @@ module Simplex.Messaging.Encoding.String
     StrEncoding (..),
     Str (..),
     strP_,
-    _strP,
     strToJSON,
     strToJEncoding,
     strParseJSON,
@@ -29,13 +28,9 @@ import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
-import Data.Set (Set)
-import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime (..))
-import Data.Time.Format.ISO8601
 import Data.Word (Word16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
@@ -97,7 +92,7 @@ instance StrEncoding Word16 where
 instance StrEncoding Char where
   strEncode = smpEncode
   {-# INLINE strEncode #-}
-  strP = smpP
+  strP = strP
   {-# INLINE strP #-}
 
 instance StrEncoding Bool where
@@ -106,26 +101,14 @@ instance StrEncoding Bool where
   strP = smpP
   {-# INLINE strP #-}
 
-instance StrEncoding Int where
-  strEncode = B.pack . show
-  {-# INLINE strEncode #-}
-  strP = A.decimal
-  {-# INLINE strP #-}
-
 instance StrEncoding Int64 where
   strEncode = B.pack . show
-  {-# INLINE strEncode #-}
   strP = A.decimal
-  {-# INLINE strP #-}
 
 instance StrEncoding SystemTime where
   strEncode = strEncode . systemSeconds
   strP = MkSystemTime <$> strP <*> pure 0
 
-instance StrEncoding UTCTime where
-  strEncode = B.pack . iso8601Show
-  strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
-
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
 strEncodeList = B.intercalate "," . map strEncode
@@ -138,12 +121,8 @@ instance StrEncoding a => StrEncoding (L.NonEmpty a) where
   strEncode = strEncodeList . L.toList
   strP = L.fromList <$> listItem `A.sepBy1'` A.char ','
 
-instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
-  strEncode = strEncodeList . S.toList
-  strP = S.fromList <$> listItem `A.sepBy'` A.char ','
-
 listItem :: StrEncoding a => Parser a
-listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
+listItem = parseAll strP <$?> A.takeTill (== ',')
 
 instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
   strEncode (a, b) = B.unwords [strEncode a, strEncode b]
@@ -172,9 +151,6 @@ instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncodin
 strP_ :: StrEncoding a => Parser a
 strP_ = strP <* A.space
 
-_strP :: StrEncoding a => Parser a
-_strP = A.space *> strP
-
 strToJSON :: StrEncoding a => a -> J.Value
 strToJSON = J.String . decodeLatin1 . strEncode
 

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,16 +1,29 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Notifications.Client where
 
 import Control.Monad.Except
 import Control.Monad.Trans.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Time (UTCTime)
 import Data.Word (Word16)
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Protocol (ConnId)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Util (bshow)
+import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Protocol (NotifierId, ProtocolServer, SMPServer)
+
+type NtfServer = ProtocolServer
 
 type NtfClient = ProtocolClient NtfResponse
 
@@ -18,7 +31,7 @@ ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> Exc
 ntfRegisterToken c pKey newTkn =
   sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
 ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
@@ -27,10 +40,7 @@ ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT Protoco
 ntfCheckToken c pKey tknId =
   sendNtfCommand c (Just pKey) tknId TCHK >>= \case
     NRTkn stat -> pure stat
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
-ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT ProtocolClientError IO ()
-ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
+    _ -> throwE PCEUnexpectedResponse
 
 ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
@@ -42,13 +52,13 @@ ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscri
 ntfCreateSubscription c pKey newSub =
   sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
   sendNtfCommand c (Just pKey) subId SCHK >>= \case
     NRSub stat -> pure stat
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
 
 ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
 ntfDeleteSubscription = okNtfCommand SDEL
@@ -61,4 +71,159 @@ okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -
 okNtfCommand cmd c pKey entId =
   sendNtfCommand c (Just pKey) entId cmd >>= \case
     NROk -> return ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE PCEUnexpectedResponse
+
+data NtfTknAction
+  = NTARegister
+  | NTAVerify NtfRegCode -- code to verify token
+  | NTACheck
+  | NTACron Word16
+  | NTADelete
+  deriving (Show)
+
+instance Encoding NtfTknAction where
+  smpEncode = \case
+    NTARegister -> "R"
+    NTAVerify code -> smpEncode ('V', code)
+    NTACheck -> "C"
+    NTACron interval -> smpEncode ('I', interval)
+    NTADelete -> "D"
+  smpP =
+    A.anyChar >>= \case
+      'R' -> pure NTARegister
+      'V' -> NTAVerify <$> smpP
+      'C' -> pure NTACheck
+      'I' -> NTACron <$> smpP
+      'D' -> pure NTADelete
+      _ -> fail "bad NtfTknAction"
+
+instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
+
+instance ToField NtfTknAction where toField = toField . smpEncode
+
+data NtfToken = NtfToken
+  { deviceToken :: DeviceToken,
+    ntfServer :: NtfServer,
+    ntfTokenId :: Maybe NtfTokenId,
+    -- | key used by the ntf server to verify transmissions
+    ntfPubKey :: C.APublicVerifyKey,
+    -- | key used by the ntf client to sign transmissions
+    ntfPrivKey :: C.APrivateSignKey,
+    -- | client's DH keys (to repeat registration if necessary)
+    ntfDhKeys :: C.KeyPair 'C.X25519,
+    -- | shared DH secret used to encrypt/decrypt notifications e2e
+    ntfDhSecret :: Maybe C.DhSecretX25519,
+    -- | token status
+    ntfTknStatus :: NtfTknStatus,
+    -- | pending token action and the earliest time
+    ntfTknAction :: Maybe NtfTknAction
+  }
+  deriving (Show)
+
+newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NtfToken
+newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys =
+  NtfToken
+    { deviceToken,
+      ntfServer,
+      ntfTokenId = Nothing,
+      ntfPubKey,
+      ntfPrivKey,
+      ntfDhKeys,
+      ntfDhSecret = Nothing,
+      ntfTknStatus = NTNew,
+      ntfTknAction = Just NTARegister
+    }
+
+data NtfSubOrSMPAction = NtfSubAction NtfSubAction | NtfSubSMPAction NtfSubSMPAction
+
+data NtfSubAction
+  = NSACreate
+  | NSACheck
+  | NSADelete
+  deriving (Show)
+
+instance Encoding NtfSubAction where
+  smpEncode = \case
+    NSACreate -> "N"
+    NSACheck -> "C"
+    NSADelete -> "D"
+  smpP =
+    A.anyChar >>= \case
+      'N' -> pure NSACreate
+      'C' -> pure NSACheck
+      'D' -> pure NSADelete
+      _ -> fail "bad NtfSubAction"
+
+instance FromField NtfSubAction where fromField = blobFieldDecoder smpDecode
+
+instance ToField NtfSubAction where toField = toField . smpEncode
+
+data NtfSubSMPAction
+  = NSAKey
+  deriving (Show)
+
+instance Encoding NtfSubSMPAction where
+  smpEncode = \case
+    NSAKey -> "K"
+  smpP =
+    A.anyChar >>= \case
+      'K' -> pure NSAKey
+      _ -> fail "bad NtfSubSMPAction"
+
+instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
+
+instance ToField NtfSubSMPAction where toField = toField . smpEncode
+
+data NtfAgentSubStatus
+  = -- | subscription started
+    NASNew
+  | -- | state after NKEY - notifier ID is assigned to queue on SMP server
+    NASKey
+  | -- | state after SNEW - subscription created on notification server
+    NASCreated NtfSubStatus
+  | -- | state after SDEL (subscription is deleted on notification server)
+    NASDeleted
+  deriving (Eq, Show)
+
+instance Encoding NtfAgentSubStatus where
+  smpEncode = \case
+    NASNew -> "NEW"
+    NASKey -> "KEY"
+    NASCreated status -> "CREATED " <> smpEncode status
+    NASDeleted -> "DELETED"
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "NEW" -> pure NASNew
+      "KEY" -> pure NASKey
+      "CREATED" -> do
+        _ <- A.space
+        NASCreated <$> smpP
+      "DELETED" -> pure NASDeleted
+      _ -> fail "bad NtfAgentSubStatus"
+
+instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
+
+instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
+
+data NtfSubscription = NtfSubscription
+  { connId :: ConnId,
+    smpServer :: SMPServer,
+    ntfQueueId :: Maybe NotifierId,
+    ntfServer :: NtfServer,
+    ntfSubId :: Maybe NtfSubscriptionId,
+    ntfSubStatus :: NtfAgentSubStatus,
+    ntfSubActionTs :: UTCTime
+  }
+  deriving (Show)
+
+newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> UTCTime -> NtfSubscription
+newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus ntfSubActionTs =
+  NtfSubscription
+    { connId,
+      smpServer,
+      ntfQueueId,
+      ntfServer,
+      ntfSubId = Nothing,
+      ntfSubStatus,
+      ntfSubActionTs
+    }

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -10,7 +10,7 @@
 
 module Simplex.Messaging.Notifications.Protocol where
 
-import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -23,14 +23,13 @@ import Data.Type.Equality
 import Data.Word (Word16)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
 import Simplex.Messaging.Parsers (fromTextField_)
 import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
-import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
+import Simplex.Messaging.Util ((<$?>))
 
 data NtfEntity = Token | Subscription
   deriving (Show)
@@ -56,7 +55,6 @@ data NtfCommandTag (e :: NtfEntity) where
   TNEW_ :: NtfCommandTag 'Token
   TVFY_ :: NtfCommandTag 'Token
   TCHK_ :: NtfCommandTag 'Token
-  TRPL_ :: NtfCommandTag 'Token
   TDEL_ :: NtfCommandTag 'Token
   TCRN_ :: NtfCommandTag 'Token
   SNEW_ :: NtfCommandTag 'Subscription
@@ -73,7 +71,6 @@ instance NtfEntityI e => Encoding (NtfCommandTag e) where
     TNEW_ -> "TNEW"
     TVFY_ -> "TVFY"
     TCHK_ -> "TCHK"
-    TRPL_ -> "TRPL"
     TDEL_ -> "TDEL"
     TCRN_ -> "TCRN"
     SNEW_ -> "SNEW"
@@ -91,7 +88,6 @@ instance ProtocolMsgTag NtfCmdTag where
     "TNEW" -> Just $ NCT SToken TNEW_
     "TVFY" -> Just $ NCT SToken TVFY_
     "TCHK" -> Just $ NCT SToken TCHK_
-    "TRPL" -> Just $ NCT SToken TRPL_
     "TDEL" -> Just $ NCT SToken TDEL_
     "TCRN" -> Just $ NCT SToken TCRN_
     "SNEW" -> Just $ NCT SSubscription SNEW_
@@ -147,8 +143,7 @@ instance Encoding ANewNtfEntity where
       _ -> fail "bad ANewNtfEntity"
 
 instance Protocol NtfResponse where
-  type ProtoCommand NtfResponse = NtfCmd
-  type ProtoType NtfResponse = 'PNTF
+  type ProtocolCommand NtfResponse = NtfCmd
   protocolClientHandshake = ntfClientHandshake
   protocolPing = NtfCmd SSubscription PING
   protocolError = \case
@@ -162,8 +157,6 @@ data NtfCommand (e :: NtfEntity) where
   TVFY :: NtfRegCode -> NtfCommand 'Token
   -- | check token status
   TCHK :: NtfCommand 'Token
-  -- | replace device token (while keeping all existing subscriptions)
-  TRPL :: DeviceToken -> NtfCommand 'Token
   -- | delete token - all subscriptions will be removed and no more notifications will be sent
   TDEL :: NtfCommand 'Token
   -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
@@ -189,7 +182,6 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
     TNEW newTkn -> e (TNEW_, ' ', newTkn)
     TVFY code -> e (TVFY_, ' ', code)
     TCHK -> e TCHK_
-    TRPL tkn -> e (TRPL_, ' ', tkn)
     TDEL -> e TDEL_
     TCRN int -> e (TCRN_, ' ', int)
     SNEW newSub -> e (SNEW_, ' ', newSub)
@@ -229,7 +221,6 @@ instance ProtocolEncoding NtfCmd where
         TNEW_ -> TNEW <$> _smpP
         TVFY_ -> TVFY <$> _smpP
         TCHK_ -> pure TCHK
-        TRPL_ -> TRPL <$> _smpP
         TDEL_ -> pure TDEL
         TCRN_ -> TCRN <$> _smpP
     NCT SSubscription tag ->
@@ -253,7 +244,7 @@ data NtfResponseTag
 
 instance Encoding NtfResponseTag where
   smpEncode = \case
-    NRTknId_ -> "IDTKN" -- it should be "TID", "SID"
+    NRTknId_ -> "IDTKN"
     NRSubId_ -> "IDSUB"
     NROk_ -> "OK"
     NRErr_ -> "ERR"
@@ -325,7 +316,7 @@ instance ProtocolEncoding NtfResponse where
         | otherwise = Left $ CMD HAS_AUTH
 
 data SMPQueueNtf = SMPQueueNtf
-  { smpServer :: SMPServer,
+  { smpServer :: ProtocolServer,
     notifierId :: NotifierId
   }
   deriving (Eq, Ord, Show)
@@ -333,47 +324,30 @@ data SMPQueueNtf = SMPQueueNtf
 instance Encoding SMPQueueNtf where
   smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
   smpP = do
-    smpServer <- updateSMPServerHosts <$> smpP
-    notifierId <- smpP
-    pure SMPQueueNtf {smpServer, notifierId}
+    (smpServer, notifierId) <- smpP
+    pure $ SMPQueueNtf smpServer notifierId
 
-instance StrEncoding SMPQueueNtf where
-  strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
-  strP = do
-    smpServer <- updateSMPServerHosts <$> strP
-    notifierId <- A.char '/' *> strP
-    pure SMPQueueNtf {smpServer, notifierId}
-
-data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
+data PushProvider = PPApns
   deriving (Eq, Ord, Show)
 
 instance Encoding PushProvider where
   smpEncode = \case
-    PPApnsDev -> "AD"
-    PPApnsProd -> "AP"
-    PPApnsTest -> "AT"
+    PPApns -> "A"
   smpP =
-    A.take 2 >>= \case
-      "AD" -> pure PPApnsDev
-      "AP" -> pure PPApnsProd
-      "AT" -> pure PPApnsTest
+    A.anyChar >>= \case
+      'A' -> pure PPApns
       _ -> fail "bad PushProvider"
 
-instance StrEncoding PushProvider where
-  strEncode = \case
-    PPApnsDev -> "apns_dev"
-    PPApnsProd -> "apns_prod"
-    PPApnsTest -> "apns_test"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "apns_dev" -> pure PPApnsDev
-      "apns_prod" -> pure PPApnsProd
-      "apns_test" -> pure PPApnsTest
-      _ -> fail "bad PushProvider"
+instance TextEncoding PushProvider where
+  textEncode = \case
+    PPApns -> "apple"
+  textDecode = \case
+    "apple" -> Just PPApns
+    _ -> Nothing
 
-instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+instance FromField PushProvider where fromField = fromTextField_ textDecode
 
-instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
+instance ToField PushProvider where toField = toField . textEncode
 
 data DeviceToken = DeviceToken PushProvider ByteString
   deriving (Eq, Ord, Show)
@@ -382,18 +356,6 @@ instance Encoding DeviceToken where
   smpEncode (DeviceToken p t) = smpEncode (p, t)
   smpP = DeviceToken <$> smpP <*> smpP
 
-instance StrEncoding DeviceToken where
-  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = DeviceToken <$> strP <* A.space <*> hexStringP
-    where
-      hexStringP =
-        A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
-          if even (B.length s) then pure s else fail "odd number of hex characters"
-
-instance ToJSON DeviceToken where
-  toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
-  toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
-
 type NtfEntityId = ByteString
 
 type NtfSubscriptionId = NtfEntityId
@@ -407,50 +369,28 @@ data NtfSubStatus
     NSPending
   | -- | connected and subscribed to SMP server
     NSActive
-  | -- | disconnected/unsubscribed from SMP server
-    NSInactive
-  | -- | END received
+  | -- | NEND received (we currently do not support it)
     NSEnd
   | -- | SMP AUTH error
-    NSAuth
-  | -- | SMP error other than AUTH
-    NSErr ByteString
+    NSSMPAuth
   deriving (Eq, Show)
 
-ntfShouldSubscribe :: NtfSubStatus -> Bool
-ntfShouldSubscribe = \case
-  NSNew -> True
-  NSPending -> True
-  NSActive -> True
-  NSInactive -> True
-  NSEnd -> False
-  NSAuth -> False
-  NSErr _ -> False
-
 instance Encoding NtfSubStatus where
   smpEncode = \case
     NSNew -> "NEW"
     NSPending -> "PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
     NSActive -> "ACTIVE"
-    NSInactive -> "INACTIVE"
     NSEnd -> "END"
-    NSAuth -> "AUTH"
-    NSErr err -> "ERR " <> err
+    NSSMPAuth -> "SMP_AUTH"
   smpP =
     A.takeTill (== ' ') >>= \case
       "NEW" -> pure NSNew
       "PENDING" -> pure NSPending
       "ACTIVE" -> pure NSActive
-      "INACTIVE" -> pure NSInactive
       "END" -> pure NSEnd
-      "AUTH" -> pure NSAuth
-      "ERR" -> NSErr <$> (A.space *> A.takeByteString)
+      "SMP_AUTH" -> pure NSSMPAuth
       _ -> fail "bad NtfSubStatus"
 
-instance StrEncoding NtfSubStatus where
-  strEncode = smpEncode
-  strP = smpP
-
 data NtfTknStatus
   = -- | Token created in DB
     NTNew
@@ -484,10 +424,6 @@ instance Encoding NtfTknStatus where
       "EXPIRED" -> pure NTExpired
       _ -> fail "bad NtfTknStatus"
 
-instance StrEncoding NtfTknStatus where
-  strEncode = smpEncode
-  strP = smpP
-
 instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
 
 instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode

src/Simplex/Messaging/Notifications/Server.hs

@@ -4,304 +4,157 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Notifications.Server where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
+import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
-import Data.List (intercalate)
-import Data.Map.Strict (Map)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
-import Simplex.Messaging.Client (ProtocolClientError (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
-import Simplex.Messaging.Notifications.Server.Stats
+import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (ErrorType (..), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
-import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
 import Simplex.Messaging.Transport.Server (runTransportServer)
 import Simplex.Messaging.Util
-import System.Exit (exitFailure)
-import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
-import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
-import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
-import UnliftIO.Directory (doesFileExist, renameFile)
+import UnliftIO (async, uninterruptibleCancel)
+import UnliftIO.Concurrent (forkFinally, threadDelay)
 import UnliftIO.Exception
 import UnliftIO.STM
 
-runNtfServer :: NtfServerConfig -> IO ()
+runNtfServer :: (MonadRandom m, MonadUnliftIO m) => NtfServerConfig -> m ()
 runNtfServer cfg = do
   started <- newEmptyTMVarIO
   runNtfServerBlocking started cfg
 
-runNtfServerBlocking :: TMVar Bool -> NtfServerConfig -> IO ()
+runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfServerConfig -> m ()
 runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
 
-type M a = ReaderT NtfEnv IO a
-
-ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
-ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
-  restoreServerStats
+ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
+ntfServer NtfServerConfig {transports} started = do
   s <- asks subscriber
   ps <- asks pushServer
-  subs <- readTVarIO =<< asks (subscriptions . store)
-  void . forkIO $ resubscribe s subs
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
   where
-    runServer :: (ServiceName, ATransport) -> M ()
+    runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
+      runTransportServer started tcpPort serverParams (runClient t)
 
-    runClient :: Transport c => TProxy c -> c -> M ()
+    runClient :: Transport c => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
       liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
         Right th -> runNtfClientTransport th
         Left _ -> pure ()
 
-    stopServer :: M ()
-    stopServer = do
-      withNtfLog closeStoreLog
-      saveServerStats
-      asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
-
-    serverStatsThread_ :: NtfServerConfig -> [M ()]
-    serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
-      [logServerStats logStatsStartTime interval serverStatsLogFile]
-    serverStatsThread_ _ = []
-
-    logServerStats :: Int -> Int -> FilePath -> M ()
-    logServerStats startAt logInterval statsFilePath = do
-      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
-      let interval = 1000000 * logInterval
-      withFile statsFilePath AppendMode $ \h -> liftIO $ do
-        hSetBuffering h LineBuffering
-        forever $ do
-          ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          tknCreated' <- atomically $ swapTVar tknCreated 0
-          tknVerified' <- atomically $ swapTVar tknVerified 0
-          tknDeleted' <- atomically $ swapTVar tknDeleted 0
-          subCreated' <- atomically $ swapTVar subCreated 0
-          subDeleted' <- atomically $ swapTVar subDeleted 0
-          ntfReceived' <- atomically $ swapTVar ntfReceived 0
-          ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
-          tkn <- atomically $ periodStatCounts activeTokens ts
-          sub <- atomically $ periodStatCounts activeSubs ts
-          hPutStrLn h $
-            intercalate
-              ","
-              [ iso8601Show $ utctDay fromTime',
-                show tknCreated',
-                show tknVerified',
-                show tknDeleted',
-                show subCreated',
-                show subDeleted',
-                show ntfReceived',
-                show ntfDelivered',
-                dayCount tkn,
-                weekCount tkn,
-                monthCount tkn,
-                dayCount sub,
-                weekCount sub,
-                monthCount sub
-              ]
-          threadDelay interval
-
-resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
-resubscribe NtfSubscriber {newSubQ} subs = do
-  d <- asks $ resubscribeDelay . config
-  forM_ subs $ \sub@NtfSubData {} ->
-    whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
-      atomically $ writeTBQueue newSubQ $ NtfSub sub
-      threadDelay d
-  liftIO $ logInfo "SMP connections resubscribed"
-
-ntfSubscriber :: NtfSubscriber -> M ()
+ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
 ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
   raceAny_ [subscribe, receiveSMP, receiveAgent]
   where
-    subscribe :: M ()
+    subscribe :: m ()
     subscribe =
       forever $
         atomically (readTBQueue newSubQ) >>= \case
           sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
             SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
-            atomically $ writeTQueue subscriberSubQ sub
+            atomically $ writeTBQueue subscriberSubQ sub
 
-    getSMPSubscriber :: SMPServer -> M SMPSubscriber
+    getSMPSubscriber :: SMPServer -> m SMPSubscriber
     getSMPSubscriber smpServer =
       atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
       where
         createSMPSubscriber = do
-          sub@SMPSubscriber {subThreadId} <- atomically newSMPSubscriber
-          atomically $ TM.insert smpServer sub smpSubscribers
-          tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub)
-          atomically . writeTVar subThreadId $ Just tId
-          pure sub
+          qSize <- asks $ subQSize . config
+          newSubscriber <- atomically $ newSMPSubscriber qSize
+          atomically $ TM.insert smpServer newSubscriber smpSubscribers
+          _ <- runSMPSubscriber newSubscriber `forkFinally` \_ -> atomically (TM.delete smpServer smpSubscribers >> failSubscriptions newSubscriber)
+          pure newSubscriber
+        -- TODO mark subscriptions as failed
+        failSubscriptions _ = pure ()
 
-    runSMPSubscriber :: SMPSubscriber -> M ()
+    runSMPSubscriber :: SMPSubscriber -> m ()
     runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
       forever $
-        atomically (peekTQueue subscriberSubQ)
-          >>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
-            updateSubStatus smpQueue NSPending
+        atomically (peekTBQueue subscriberSubQ) >>= \case
+          NtfSub NtfSubData {smpQueue, notifierKey} -> do
             let SMPQueueNtf {smpServer, notifierId} = smpQueue
             liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
               Right _ -> do
-                updateSubStatus smpQueue NSActive
-                void . atomically $ readTQueue subscriberSubQ
-              Left err -> do
-                handleSubError smpQueue err
-                case err of
-                  PCEResponseTimeout -> pure ()
-                  PCENetworkError -> pure ()
-                  _ -> void . atomically $ readTQueue subscriberSubQ
+                -- update subscription status
+                _ <- atomically $ readTBQueue subscriberSubQ
+                pure ()
+              Left _e -> pure ()
 
-    receiveSMP :: M ()
+    receiveSMP :: m ()
     receiveSMP = forever $ do
-      (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
-      let smpQueue = SMPQueueNtf srv ntfId
+      (srv, _sessId, ntfId, msg) <- atomically $ readTBQueue msgQ
       case msg of
-        SMP.NMSG nmsgNonce encNMsgMeta -> do
-          ntfTs <- liftIO getSystemTime
-          st <- asks store
+        SMP.NMSG -> do
           NtfPushServer {pushQ} <- asks pushServer
-          stats <- asks serverStats
-          atomically $ updatePeriodStats (activeSubs stats) ntfId
+          st <- asks store
           atomically $
-            findNtfSubscriptionToken st smpQueue
-              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
-          incNtfStat ntfReceived
-        SMP.END -> updateSubStatus smpQueue NSEnd
+            findNtfSubscriptionToken st (SMPQueueNtf srv ntfId)
+              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage srv ntfId))
         _ -> pure ()
+      pure ()
 
     receiveAgent =
       forever $
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
-          CADisconnected srv subs -> do
-            logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
-            forM_ subs $ \(_, ntfId) -> do
-              let smpQueue = SMPQueueNtf srv ntfId
-              updateSubStatus smpQueue NSInactive
-          CAReconnected srv ->
-            logInfo $ "SMP server reconnected " <> showServer' srv
-          CAResubscribed srv sub -> do
-            let ntfId = snd sub
-                smpQueue = SMPQueueNtf srv ntfId
-            updateSubStatus smpQueue NSActive
-          CASubError srv (_, ntfId) err -> do
-            logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
-            handleSubError (SMPQueueNtf srv ntfId) err
-      where
-        showServer' = decodeLatin1 . strEncode . host
+          CADisconnected _srv _subs -> do
+            -- update subscription statuses
+            pure ()
+          CAReconnected _ -> pure ()
+          CAResubscribed _srv _sub -> do
+            -- update subscription status
+            pure ()
+          CASubError _srv _sub _err -> do
+            -- update subscription status
+            pure ()
 
-    handleSubError :: SMPQueueNtf -> ProtocolClientError -> M ()
-    handleSubError smpQueue = \case
-      PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
-      PCEProtocolError e -> updateErr "SMP error " e
-      PCEIOError e -> updateErr "IOError " e
-      PCEResponseError e -> updateErr "ResponseError " e
-      PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
-      PCETransportError e -> updateErr "TransportError " e
-      PCESignatureError e -> updateErr "SignatureError " e
-      PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
-      PCEResponseTimeout -> pure ()
-      PCENetworkError -> pure ()
-      where
-        updateErr :: Show e => ByteString -> e -> M ()
-        updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
-
-    updateSubStatus smpQueue status = do
-      st <- asks store
-      atomically (findNtfSubscription st smpQueue)
-        >>= mapM_
-          ( \NtfSubData {ntfSubId, subStatus} -> do
-              atomically $ writeTVar subStatus status
-              withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status
-          )
-
-ntfPush :: NtfPushServer -> M ()
-ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
+ntfPush :: MonadUnliftIO m => NtfPushServer -> m ()
+ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
+  (tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  logDebug $ "sending push notification to " <> T.pack (show pp)
   status <- readTVarIO tknStatus
-  case ntf of
-    PNVerification _
-      | status /= NTInvalid && status /= NTExpired ->
-        deliverNotification pp tkn ntf >>= \case
-          Right _ -> do
-            status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
-            forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
-          _ -> pure ()
-      | otherwise -> logError "bad notification token status"
-    PNCheckMessages -> checkActiveTkn status $ do
-      void $ deliverNotification pp tkn ntf
-    PNMessage {} -> checkActiveTkn status $ do
-      stats <- asks serverStats
-      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
-      void $ deliverNotification pp tkn ntf
-      incNtfStat ntfDelivered
+  case (status, ntf) of
+    (_, PNVerification _) -> do
+      -- TODO check token status
+      deliverNotification pp tkn ntf
+      atomically $ modifyTVar tknStatus $ \status' -> if status' == NTActive then NTActive else NTConfirmed
+    (NTActive, PNCheckMessages) -> do
+      deliverNotification pp tkn ntf
+    (NTActive, PNMessage _ _) -> do
+      deliverNotification pp tkn ntf
+    _ -> do
+      logError "bad notification token status"
   where
-    checkActiveTkn :: NtfTknStatus -> M () -> M ()
-    checkActiveTkn status action
-      | status == NTActive = action
-      | otherwise = liftIO $ logError "bad notification token status"
-    deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ())
-    deliverNotification pp tkn@NtfTknData {ntfTknId, tknStatus} ntf = do
+    deliverNotification :: PushProvider -> PushProviderClient
+    deliverNotification pp tkn ntf = do
       deliver <- liftIO $ getPushClient s pp
-      liftIO (runExceptT $ deliver tkn ntf) >>= \case
-        Right _ -> pure $ Right ()
-        Left e -> case e of
-          PPConnection _ -> retryDeliver
-          PPRetryLater -> retryDeliver
-          PPCryptoError _ -> err e
-          PPResponseError _ _ -> err e
-          PPTokenInvalid -> updateTknStatus NTInvalid >> err e
-          PPPermanentError -> err e
-      where
-        retryDeliver :: M (Either PushProviderError ())
-        retryDeliver = do
-          deliver <- liftIO $ newPushClient s pp
-          liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
-        updateTknStatus :: NtfTknStatus -> M ()
-        updateTknStatus status = do
-          atomically $ writeTVar tknStatus status
-          withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
-        err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
+      -- TODO retry later based on the error
+      deliver tkn ntf `catchError` \e -> logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e
 
-runNtfClientTransport :: Transport c => THandle c -> M ()
+runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
 runNtfClientTransport th@THandle {sessionId} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
@@ -309,33 +162,32 @@ runNtfClientTransport th@THandle {sessionId} = do
   s <- asks subscriber
   ps <- asks pushServer
   expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
-    `finally` liftIO (clientDisconnected c)
+  raceAny_ ([send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
+    `finally` clientDisconnected c
   where
-    disconnectThread_ c expCfg = maybe [] ((: []) . liftIO . disconnectTransport th c activeAt) expCfg
+    disconnectThread_ c expCfg = maybe [] ((: []) . disconnectTransport th c activeAt) expCfg
 
-clientDisconnected :: NtfServerClient -> IO ()
+clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
-receive :: Transport c => THandle c -> NtfServerClient -> M ()
+receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
 receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- tGet th
-  forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
-    atomically . writeTVar activeAt =<< liftIO getSystemTime
-    logDebug "received transmission"
-    case cmdOrError of
-      Left e -> write sndQ (corrId, entId, NRErr e)
-      Right cmd ->
-        verifyNtfTransmission t cmd >>= \case
-          VRVerified req -> write rcvQ req
-          VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
+  t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
+  atomically . writeTVar activeAt =<< liftIO getSystemTime
+  logDebug "received transmission"
+  case cmdOrError of
+    Left e -> write sndQ (corrId, entId, NRErr e)
+    Right cmd ->
+      verifyNtfTransmission t cmd >>= \case
+        VRVerified req -> write rcvQ req
+        VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
   where
     write q t = atomically $ writeTBQueue q t
 
-send :: Transport c => THandle c -> NtfServerClient -> IO ()
+send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
 send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
+  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
@@ -343,7 +195,8 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = for
 
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
-verifyNtfTransmission :: SignedTransmission NtfCmd -> NtfCmd -> M VerificationResult
+verifyNtfTransmission ::
+  forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => SignedTransmission NtfCmd -> NtfCmd -> m VerificationResult
 verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
   st <- asks store
   case cmd of
@@ -364,11 +217,13 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
       s_ <- atomically $ findNtfSubscription st smpQueue
       case s_ of
         Nothing -> do
+          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st tknId
           verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
         Just s@NtfSubData {tokenId = subTknId} ->
           if subTknId == tknId
             then do
+              -- TODO move active token check here to differentiate error
               t_ <- atomically $ getActiveNtfToken st subTknId
               verifyToken' t_ $ verifiedSubCmd s c
             else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
@@ -376,13 +231,14 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
       s_ <- atomically $ getNtfSubscription st entId
       case s_ of
         Just s@NtfSubData {tokenId = subTknId} -> do
+          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st subTknId
           verifyToken' t_ $ verifiedSubCmd s c
         _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
   where
     verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
     verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
-    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult
+    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> m VerificationResult
     verifyToken t_ positiveVerificationResult =
       pure $ case t_ of
         Just t@NtfTknData {tknVerifyKey} ->
@@ -390,17 +246,17 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
             then positiveVerificationResult t
             else VRFailed
         _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult
+    verifyToken' :: Maybe NtfTknData -> VerificationResult -> m VerificationResult
     verifyToken' t_ = verifyToken t_ . const
 
-client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
-client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
+client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
+client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ, intervalNotifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: NtfRequest -> M (Transmission NtfResponse)
+    processCommand :: NtfRequest -> m (Transmission NtfResponse)
     processCommand = \case
       NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
         logDebug "TNEW - new token"
@@ -409,13 +265,12 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         let dhSecret = C.dh' dhPubKey srvDhPrivKey
         tknId <- getId
         regCode <- getRegCode
-        tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode
-        atomically $ addNtfToken st tknId tkn
-        atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
-        withNtfLog (`logCreateToken` tkn)
-        incNtfStat tknCreated
+        atomically $ do
+          tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
+          addNtfToken st tknId tkn
+          writeTBQueue pushQ (tkn, PNVerification regCode)
         pure (corrId, "", NRTknId tknId srvDhPubKey)
-      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
+      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
         (corrId,tknId,) <$> case cmd of
           TNEW (NewNtfTkn _ _ dhPubKey) -> do
@@ -434,57 +289,31 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               atomically $ writeTVar tknStatus NTActive
               tIds <- atomically $ removeInactiveTokenRegistrations st tkn
               forM_ tIds cancelInvervalNotifications
-              withNtfLog $ \s -> logTokenStatus s tknId NTActive
-              incNtfStat tknVerified
               pure NROk
             | otherwise -> do
               logDebug "TVFY - incorrect code or token status"
               pure $ NRErr AUTH
-          TCHK -> do
-            logDebug "TCHK"
-            pure $ NRTkn status
-          TRPL token' -> do
-            logDebug "TRPL - replace token"
-            st <- asks store
-            regCode <- getRegCode
-            atomically $ do
-              removeTokenRegistration st tkn
-              writeTVar tknStatus NTRegistered
-              let tkn' = tkn {token = token', tknRegCode = regCode}
-              addNtfToken st tknId tkn'
-              writeTBQueue pushQ (tkn', PNVerification regCode)
-            withNtfLog $ \s -> logUpdateToken s tknId token' regCode
-            incNtfStat tknDeleted
-            incNtfStat tknCreated
-            pure NROk
+          TCHK -> pure $ NRTkn status
           TDEL -> do
             logDebug "TDEL"
             st <- asks store
-            qs <- atomically $ deleteNtfToken st tknId
-            forM_ qs $ \SMPQueueNtf {smpServer, notifierId} ->
-              atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
+            atomically $ deleteNtfToken st tknId
             cancelInvervalNotifications tknId
-            withNtfLog (`logDeleteToken` tknId)
-            incNtfStat tknDeleted
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
-            atomically $ writeTVar tknCronInterval 0
             cancelInvervalNotifications tknId
-            withNtfLog $ \s -> logTokenCron s tknId 0
             pure NROk
           TCRN int
             | int < 20 -> pure $ NRErr QUOTA
             | otherwise -> do
               logDebug "TCRN"
-              atomically $ writeTVar tknCronInterval int
               atomically (TM.lookup tknId intervalNotifiers) >>= \case
                 Nothing -> runIntervalNotifier int
                 Just IntervalNotifier {interval, action} ->
                   unless (interval == int) $ do
                     uninterruptibleCancel action
                     runIntervalNotifier int
-              withNtfLog $ \s -> logTokenCron s tknId int
               pure NROk
             where
               runIntervalNotifier interval = do
@@ -499,78 +328,77 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         logDebug "SNEW - new subscription"
         st <- asks store
         subId <- getId
-        sub <- atomically $ mkNtfSubData subId newSub
-        resp <-
-          atomically (addNtfSubscription st subId sub) >>= \case
-            Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
-            _ -> pure $ NRErr AUTH
-        withNtfLog (`logCreateSubscription` sub)
-        incNtfStat subCreated
-        pure (corrId, "", resp)
-      NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
+        atomically $ do
+          sub <- mkNtfSubData newSub
+          (corrId,"",)
+            <$> ( addNtfSubscription st subId sub >>= \case
+                    Just _ -> writeTBQueue newSubQ (NtfSub sub) $> NRSubId subId
+                    _ -> pure $ NRErr AUTH
+                )
+      NtfReqCmd SSubscription (NtfSub NtfSubData {notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
           SNEW (NewNtfSub _ _ notifierKey) -> do
             logDebug "SNEW - existing subscription"
-            -- possible improvement: retry if subscription failed, if pending or AUTH do nothing
+            -- TODO retry if subscription failed, if pending or AUTH do nothing
             pure $
               if notifierKey == registeredNKey
                 then NRSubId subId
                 else NRErr AUTH
-          SCHK -> do
-            logDebug "SCHK"
-            pure $ NRSub status
-          SDEL -> do
-            logDebug "SDEL"
-            st <- asks store
-            atomically $ deleteNtfSubscription st subId
-            atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
-            withNtfLog (`logDeleteSubscription` subId)
-            incNtfStat subDeleted
-            pure NROk
+          SCHK -> pure $ NRSub status
+          SDEL -> pure NROk
           PING -> pure NRPong
-    getId :: M NtfEntityId
+    getId :: m NtfEntityId
     getId = getRandomBytes =<< asks (subIdBytes . config)
-    getRegCode :: M NtfRegCode
+    getRegCode :: m NtfRegCode
     getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
-    getRandomBytes :: Int -> M ByteString
+    getRandomBytes :: Int -> m ByteString
     getRandomBytes n = do
       gVar <- asks idsDrg
       atomically (C.pseudoRandomBytes n gVar)
-    cancelInvervalNotifications :: NtfTokenId -> M ()
+    cancelInvervalNotifications :: NtfTokenId -> m ()
     cancelInvervalNotifications tknId =
       atomically (TM.lookupDelete tknId intervalNotifiers)
         >>= mapM_ (uninterruptibleCancel . action)
 
-withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
-withNtfLog action = liftIO . mapM_ action =<< asks storeLog
-
-incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
-incNtfStat statSel = do
-  stats <- asks serverStats
-  atomically $ modifyTVar' (statSel stats) (+ 1)
-
-saveServerStats :: M ()
-saveServerStats =
-  asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
-  where
-    saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
-      B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
-
-restoreServerStats :: M ()
-restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
-  where
-    restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
-      liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d -> do
-          s <- asks serverStats
-          atomically $ setNtfServerStats s d
-          renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
-        Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
-          liftIO exitFailure
+-- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk)
+-- do
+-- st <- asks store
+-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
+-- let dhSecret = C.dh' dhPubKey privDhKey
+-- sub <- atomically $ mkNtfSubsciption smpQueue token verifyKey dhSecret
+-- addSubRetry 3 st sub >>= \case
+--   Nothing -> pure (corrId, "", NRErr INTERNAL)
+--   Just sId -> do
+--     atomically $ writeTBQueue subQ sub
+--     pure (corrId, sId, NRSubId pubDhKey)
+-- where
+--   addSubRetry :: Int -> NtfSubscriptionsStore -> NtfSubsciption -> m (Maybe NtfSubsciptionId)
+--   addSubRetry 0 _ _ = pure Nothing
+--   addSubRetry n st sub = do
+--     sId <- getId
+--     -- create QueueRec record with these ids and keys
+--     atomically (addNtfSub st sId sub) >>= \case
+--       Nothing -> addSubRetry (n - 1) st sub
+--       _ -> pure $ Just sId
+--   getId :: m NtfSubsciptionId
+--   getId = do
+--     n <- asks $ subIdBytes . config
+--     gVar <- asks idsDrg
+--     atomically (randomBytes n gVar)
+-- NReqCommand sub@NtfSubsciption {tokenId, subStatus} (corrId, subId, cmd) ->
+--   (corrId,subId,) <$> case cmd of
+--     NCSubCreate tokenId smpQueue -> pure NROk
+-- do
+--   st <- asks store
+--   (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
+--   let dhSecret = C.dh' (dhPubKey newSub) privDhKey
+--   atomically (updateNtfSub st sub newSub dhSecret) >>= \case
+--     Nothing -> pure $ NRErr INTERNAL
+--     _ -> atomically $ do
+--       whenM ((== NSEnd) <$> readTVar status) $ writeTBQueue subQ sub
+--       pure $ NRSubId pubDhKey
+-- NCSubCheck -> NRStat <$> readTVarIO subStatus
+-- NCSubDelete -> do
+--   st <- asks store
+--   atomically (deleteNtfSub st subId) $> NROk

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

@@ -2,16 +2,16 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Notifications.Server.Env where
 
-import Control.Concurrent (ThreadId)
 import Control.Concurrent.Async (Async)
+import Control.Monad (void)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
-import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Word (Word16)
 import Data.X509.Validation (Fingerprint (..))
@@ -22,17 +22,13 @@ import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
-import System.IO (IOMode (..))
-import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data NtfServerConfig = NtfServerConfig
@@ -45,18 +41,10 @@ data NtfServerConfig = NtfServerConfig
     smpAgentCfg :: SMPClientAgentConfig,
     apnsConfig :: APNSPushClientConfig,
     inactiveClientExpiration :: Maybe ExpirationConfig,
-    storeLogFile :: Maybe FilePath,
-    resubscribeDelay :: Int, -- microseconds
     -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath,
-    -- stats config - see SMP server config
-    logStatsInterval :: Maybe Int,
-    logStatsStartTime :: Int,
-    serverStatsLogFile :: FilePath,
-    serverStatsBackupFile :: Maybe FilePath,
-    logTLSErrors :: Bool
+    certificateFile :: FilePath
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig
@@ -71,25 +59,23 @@ data NtfEnv = NtfEnv
     subscriber :: NtfSubscriber,
     pushServer :: NtfPushServer,
     store :: NtfStore,
-    storeLog :: Maybe (StoreLog 'WriteMode),
     idsDrg :: TVar ChaChaDRG,
     serverIdentity :: C.KeyHash,
     tlsServerParams :: T.ServerParams,
-    serverIdentity :: C.KeyHash,
-    serverStats :: NtfServerStats
+    serverIdentity :: C.KeyHash
   }
 
 newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
+newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, caCertificateFile, certificateFile, privateKeyFile} = do
   idsDrg <- newTVarIO =<< drgNew
   store <- atomically newNtfStore
-  storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
   subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
   pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
+  -- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server
+  void . liftIO $ newPushClient pushServer PPApns
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
-  serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
-  pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+  pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
@@ -104,16 +90,14 @@ newNtfSubscriber qSize smpAgentCfg = do
   smpAgent <- newSMPClientAgent smpAgentCfg
   pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
 
-data SMPSubscriber = SMPSubscriber
-  { newSubQ :: TQueue (NtfEntityRec 'Subscription),
-    subThreadId :: TVar (Maybe (Weak ThreadId))
+newtype SMPSubscriber = SMPSubscriber
+  { newSubQ :: TBQueue (NtfEntityRec 'Subscription)
   }
 
-newSMPSubscriber :: STM SMPSubscriber
-newSMPSubscriber = do
-  newSubQ <- newTQueue
-  subThreadId <- newTVar Nothing
-  pure SMPSubscriber {newSubQ, subThreadId}
+newSMPSubscriber :: Natural -> STM SMPSubscriber
+newSMPSubscriber qSize = do
+  newSubQ <- newTBQueue qSize
+  pure SMPSubscriber {newSubQ}
 
 data NtfPushServer = NtfPushServer
   { pushQ :: TBQueue (NtfTknData, PushNotification),
@@ -136,10 +120,11 @@ newNtfPushServer qSize apnsConfig = do
   pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  c <- apnsPushProviderClient <$> createAPNSPushClient (apnsProviderHost pp) apnsConfig
-  atomically $ TM.insert pp c pushClients
-  pure c
+newPushClient NtfPushServer {apnsConfig, pushClients} = \case
+  PPApns -> do
+    c <- apnsPushProviderClient <$> createAPNSPushClient apnsConfig
+    atomically $ TM.insert PPApns c pushClients
+    pure c
 
 getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 getPushClient s@NtfPushServer {pushClients} pp =

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

@@ -1,174 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Simplex.Messaging.Notifications.Server.Main where
-
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
-import Network.Socket (HostName)
-import Options.Applicative
-import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Server (runNtfServer)
-import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
-import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
-import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Transport.Client (TransportHost (..))
-import System.Directory (createDirectoryIfMissing, doesFileExist)
-import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
-import Text.Read (readMaybe)
-
-ntfServerVersion :: String
-ntfServerVersion = "1.3.0"
-
-ntfServerCLI :: FilePath -> FilePath -> IO ()
-ntfServerCLI cfgPath logPath =
-  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
-    Init opts ->
-      doesFileExist iniFile >>= \case
-        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
-        _ -> initializeServer opts
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-      deleteDirIfExists cfgPath
-      deleteDirIfExists logPath
-      putStrLn "Deleted configuration and log files"
-  where
-    iniFile = combine cfgPath "ntf-server.ini"
-    serverVersion = "SMP notifications server v" <> ntfServerVersion
-    defaultServerPort = "443"
-    executableName = "ntf-server"
-    storeLogFilePath = combine logPath "ntf-server-store.log"
-    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
-      clearDirIfExists cfgPath
-      clearDirIfExists logPath
-      createDirectoryIfMissing True cfgPath
-      createDirectoryIfMissing True logPath
-      let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
-      fp <- createServerX509 cfgPath x509cfg
-      let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
-      writeFile iniFile $ iniFileContent host
-      putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
-      warnCAPrivateKeyFile cfgPath x509cfg
-      printServiceInfo serverVersion srv
-      where
-        iniFileContent host =
-          "[STORE_LOG]\n\
-          \# The server uses STM memory for persistence,\n\
-          \# that will be lost on restart (e.g., as with redis).\n\
-          \# This option enables saving memory to append only log,\n\
-          \# and restoring it when the server is started.\n\
-          \# Log is compacted on start (deleted objects are removed).\n"
-            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-            <> "log_stats: off\n\n\
-               \[TRANSPORT]\n\
-               \# host is only used to print server address on start\n"
-            <> ("host: " <> host <> "\n")
-            <> ("port: " <> defaultServerPort <> "\n")
-            <> "log_tls_errors: off\n\
-               \websockets: off\n"
-    runServer ini = do
-      hSetBuffering stdout LineBuffering
-      hSetBuffering stderr LineBuffering
-      fp <- checkSavedFingerprint cfgPath defaultX509Config
-      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
-          port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
-      printServiceInfo serverVersion srv
-      printServerConfig transports storeLogFile
-      runNtfServer cfg
-      where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-        logStats = settingIsOn "STORE_LOG" "log_stats" ini
-        c = combine cfgPath . ($ defaultX509Config)
-        serverConfig =
-          NtfServerConfig
-            { transports = iniTransports ini,
-              subIdBytes = 24,
-              regCodeBytes = 32,
-              clientQSize = 16,
-              subQSize = 64,
-              pushQSize = 128,
-              smpAgentCfg = defaultSMPClientAgentConfig,
-              apnsConfig = defaultAPNSPushClientConfig,
-              inactiveClientExpiration = Nothing,
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              resubscribeDelay = 50000, -- 50ms
-              caCertificateFile = c caCrtFile,
-              privateKeyFile = c serverKeyFile,
-              certificateFile = c serverCrtFile,
-              logStatsInterval = logStats $> 86400, -- seconds
-              logStatsStartTime = 0, -- seconds from 00:00 UTC
-              serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
-              serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
-              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-            }
-
-data CliCommand
-  = Init InitOptions
-  | Start
-  | Delete
-
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName
-  }
-  deriving (Show)
-
-cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
-cliCommandP cfgPath logPath iniFile =
-  hsubparser
-    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
-        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
-    )
-  where
-    initP :: Parser InitOptions
-    initP =
-      InitOptions
-        <$> switch
-          ( long "store-log"
-              <> short 'l'
-              <> help "Enable store log for persistence"
-          )
-        <*> option
-          (maybeReader readMaybe)
-          ( long "sign-algorithm"
-              <> short 'a'
-              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
-              <> value ED448
-              <> showDefault
-              <> metavar "ALG"
-          )
-        <*> strOption
-          ( long "ip"
-              <> help
-                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
-              <> value "127.0.0.1"
-              <> showDefault
-              <> metavar "IP"
-          )
-        <*> (optional . strOption)
-          ( long "fqdn"
-              <> short 'n'
-              <> help "Server FQDN used as Common Name for TLS online certificate"
-              <> showDefault
-              <> metavar "FQDN"
-          )

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

@@ -10,7 +10,6 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
-import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Crypto.Hash.Algorithms (SHA256 (..))
@@ -34,6 +33,7 @@ import Data.Int (Int64)
 import Data.Map.Strict (Map)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8With)
 import Data.Time.Clock.System
 import qualified Data.X509 as X
 import GHC.Generics (Generic)
@@ -46,9 +46,8 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
-import Simplex.Messaging.Protocol (EncNMsgMeta)
+import Simplex.Messaging.Protocol (NotifierId, SMPServer)
 import Simplex.Messaging.Transport.HTTP2.Client
-import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
@@ -90,31 +89,15 @@ signedJWTToken pk (JWTToken hdr claims) = do
 
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
-  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  -- TODO this is specific to APNS key
   [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
   pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
 
 data PushNotification
   = PNVerification NtfRegCode
-  | PNMessage PNMessageData
-  -- | PNAlert Text
+  | PNMessage SMPServer NotifierId
+  | PNAlert Text
   | PNCheckMessages
-  deriving (Show)
-
-data PNMessageData = PNMessageData
-  { smpQueue :: SMPQueueNtf,
-    ntfTs :: SystemTime,
-    nmsgNonce :: C.CbNonce,
-    encNMsgMeta :: EncNMsgMeta
-  }
-  deriving (Show)
-
-instance StrEncoding PNMessageData where
-  strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
-    strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
-  strP = do
-    (smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
-    pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
 
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show, Generic)
@@ -124,9 +107,9 @@ instance ToJSON APNSNotification where
   toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
 data APNSNotificationBody
-  = APNSBackground {contentAvailable :: Int}
+  = APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
+  | APNSBackground {contentAvailable :: Int}
   | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text}
-  | APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
   deriving (Show, Generic)
 
 apnsJSONOptions :: J.Options
@@ -193,27 +176,23 @@ data APNSPushClientConfig = APNSPushClientConfig
     paddedNtfLength :: Int,
     appName :: ByteString,
     appTeamId :: Text,
+    apnsHost :: HostName,
     apnsPort :: ServiceName,
     http2cfg :: HTTP2ClientConfig
   }
   deriving (Show)
 
-apnsProviderHost :: PushProvider -> HostName
-apnsProviderHost = \case
-  PPApnsTest -> "localhost"
-  PPApnsDev -> "api.sandbox.push.apple.com"
-  PPApnsProd -> "api.push.apple.com"
-
 defaultAPNSPushClientConfig :: APNSPushClientConfig
 defaultAPNSPushClientConfig =
   APNSPushClientConfig
-    { tokenTTL = 1800, -- 30 minutes
+    { tokenTTL = 1200, -- 20 minutes
       authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
       authKeyAlg = "ES256",
       authKeyIdEnv = "APNS_KEY_ID",
-      paddedNtfLength = 512,
+      paddedNtfLength = 256,
       appName = "chat.simplex.app",
       appTeamId = "5NN7GUYB6T",
+      apnsHost = "api.sandbox.push.apple.com",
       apnsPort = "443",
       http2cfg = defaultHTTP2ClientConfig
     }
@@ -224,20 +203,19 @@ data APNSPushClient = APNSPushClient
     jwtHeader :: JWTHeader,
     jwtToken :: TVar (JWTToken, SignedJWTToken),
     nonceDrg :: TVar ChaChaDRG,
-    apnsHost :: HostName,
     apnsCfg :: APNSPushClientConfig
   }
 
-createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
-createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
+createAPNSPushClient :: APNSPushClientConfig -> IO APNSPushClient
+createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
   https2Client <- newTVarIO Nothing
-  void $ connectHTTPS2 apnsHost apnsCfg https2Client
+  void $ connectHTTPS2 apnsCfg https2Client
   privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
   let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
   nonceDrg <- drgNew >>= newTVarIO
-  pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
+  pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsCfg}
 
 getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
 getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do
@@ -258,8 +236,8 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
   signedJWT <- signedJWTToken privateKey jwt
   pure (jwt, signedJWT)
 
-connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
-connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
+connectHTTPS2 :: APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
+connectHTTPS2 APNSPushClientConfig {apnsHost, apnsPort, http2cfg} https2Client = do
   r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
   case r of
     Right client -> atomically . writeTVar https2Client $ Just client
@@ -269,32 +247,30 @@ connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client =
     disconnected = atomically $ writeTVar https2Client Nothing
 
 getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
-getApnsHTTP2Client APNSPushClient {https2Client, apnsHost, apnsCfg} =
-  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsHost apnsCfg https2Client) (pure . Right)
+getApnsHTTP2Client APNSPushClient {https2Client, apnsCfg} =
+  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right)
 
 disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
 disconnectApnsHTTP2Client APNSPushClient {https2Client} =
   readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
 
-ntfCategoryCheckMessage :: Text
-ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
-
 apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
 apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
   PNVerification (NtfRegCode code) ->
     encrypt code $ \code' ->
-      apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
-  PNMessage pnMessageData ->
-    encrypt (strEncode pnMessageData) $ \ntfData ->
-      apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
-  -- PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
+      apn APNSBackground {contentAvailable = 1} . Just $ J.object ["verification" .= code', "nonce" .= nonce]
+  PNMessage srv nId ->
+    encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue ->
+      apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue, "nonce" .= nonce]
+  PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
   PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
   where
     encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
     encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
     apn aps notificationData = APNSNotification {aps, notificationData}
-    apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or another app event", category = Just ntfCategoryCheckMessage}
-    -- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
+    apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or some other app event", category = Nothing}
+    apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
+    safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?'
 
 apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
 apnsRequest c tkn ntf@APNSNotification {aps} = do
@@ -322,7 +298,7 @@ data PushProviderError
   | PPTokenInvalid
   | PPRetryLater
   | PPPermanentError
-  deriving (Show, Exception)
+  deriving (Show)
 
 type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
 
@@ -331,7 +307,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
   deriving (Generic, FromJSON)
 
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApns tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
@@ -357,7 +333,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
         _ -> err status reason'
       | status == Just N.gone410 = throwError PPTokenInvalid
       | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-      -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
+      -- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token
       | otherwise = err status reason'
     err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
     err s r = throwError $ PPResponseError s r

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

@@ -1,113 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Server.Stats where
-
-import Control.Applicative (optional)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Time.Clock (UTCTime)
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
-import Simplex.Messaging.Protocol (NotifierId)
-import Simplex.Messaging.Server.Stats
-import UnliftIO.STM
-
-data NtfServerStats = NtfServerStats
-  { fromTime :: TVar UTCTime,
-    tknCreated :: TVar Int,
-    tknVerified :: TVar Int,
-    tknDeleted :: TVar Int,
-    subCreated :: TVar Int,
-    subDeleted :: TVar Int,
-    ntfReceived :: TVar Int,
-    ntfDelivered :: TVar Int,
-    activeTokens :: PeriodStats NtfTokenId,
-    activeSubs :: PeriodStats NotifierId
-  }
-
-data NtfServerStatsData = NtfServerStatsData
-  { _fromTime :: UTCTime,
-    _tknCreated :: Int,
-    _tknVerified :: Int,
-    _tknDeleted :: Int,
-    _subCreated :: Int,
-    _subDeleted :: Int,
-    _ntfReceived :: Int,
-    _ntfDelivered :: Int,
-    _activeTokens :: PeriodStatsData NtfTokenId,
-    _activeSubs :: PeriodStatsData NotifierId
-  }
-
-newNtfServerStats :: UTCTime -> STM NtfServerStats
-newNtfServerStats ts = do
-  fromTime <- newTVar ts
-  tknCreated <- newTVar 0
-  tknVerified <- newTVar 0
-  tknDeleted <- newTVar 0
-  subCreated <- newTVar 0
-  subDeleted <- newTVar 0
-  ntfReceived <- newTVar 0
-  ntfDelivered <- newTVar 0
-  activeTokens <- newPeriodStats
-  activeSubs <- newPeriodStats
-  pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
-
-getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
-getNtfServerStatsData s = do
-  _fromTime <- readTVar $ fromTime (s :: NtfServerStats)
-  _tknCreated <- readTVar $ tknCreated s
-  _tknVerified <- readTVar $ tknVerified s
-  _tknDeleted <- readTVar $ tknDeleted s
-  _subCreated <- readTVar $ subCreated s
-  _subDeleted <- readTVar $ subDeleted s
-  _ntfReceived <- readTVar $ ntfReceived s
-  _ntfDelivered <- readTVar $ ntfDelivered s
-  _activeTokens <- getPeriodStatsData $ activeTokens s
-  _activeSubs <- getPeriodStatsData $ activeSubs s
-  pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
-
-setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
-setNtfServerStats s d = do
-  writeTVar (fromTime (s :: NtfServerStats)) $! _fromTime (d :: NtfServerStatsData)
-  writeTVar (tknCreated s) $! _tknCreated d
-  writeTVar (tknVerified s) $! _tknVerified d
-  writeTVar (tknDeleted s) $! _tknDeleted d
-  writeTVar (subCreated s) $! _subCreated d
-  writeTVar (subDeleted s) $! _subDeleted d
-  writeTVar (ntfReceived s) $! _ntfReceived d
-  writeTVar (ntfDelivered s) $! _ntfDelivered d
-  setPeriodStats (activeTokens s) (_activeTokens d)
-  setPeriodStats (activeSubs s) (_activeSubs d)
-
-instance StrEncoding NtfServerStatsData where
-  strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
-    B.unlines
-      [ "fromTime=" <> strEncode _fromTime,
-        "tknCreated=" <> strEncode _tknCreated,
-        "tknVerified=" <> strEncode _tknVerified,
-        "tknDeleted=" <> strEncode _tknDeleted,
-        "subCreated=" <> strEncode _subCreated,
-        "subDeleted=" <> strEncode _subDeleted,
-        "ntfReceived=" <> strEncode _ntfReceived,
-        "ntfDelivered=" <> strEncode _ntfDelivered,
-        "activeTokens:",
-        strEncode _activeTokens,
-        "activeSubs:",
-        strEncode _activeSubs
-      ]
-  strP = do
-    _fromTime <- "fromTime=" *> strP <* A.endOfLine
-    _tknCreated <- "tknCreated=" *> strP <* A.endOfLine
-    _tknVerified <- "tknVerified=" *> strP <* A.endOfLine
-    _tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
-    _subCreated <- "subCreated=" *> strP <* A.endOfLine
-    _subDeleted <- "subDeleted=" *> strP <* A.endOfLine
-    _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
-    _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
-    _ <- "activeTokens:" <* A.endOfLine
-    _activeTokens <- strP <* A.endOfLine
-    _ <- "activeSubs:" <* A.endOfLine
-    _activeSubs <- strP <* optional A.endOfLine
-    pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}

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

@@ -12,12 +12,9 @@ module Simplex.Messaging.Notifications.Server.Store where
 import Control.Concurrent.STM
 import Control.Monad
 import Data.ByteString.Char8 (ByteString)
-import Data.Functor (($>))
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes)
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Protocol (NtfPrivateSignKey)
@@ -27,7 +24,6 @@ import Simplex.Messaging.Util (whenM, ($>>=))
 
 data NtfStore = NtfStore
   { tokens :: TMap NtfTokenId NtfTknData,
-    -- multiple registrations exist to protect from malicious registrations if token is compromised
     tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
     subscriptions :: TMap NtfSubscriptionId NtfSubData,
     tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
@@ -50,19 +46,26 @@ data NtfTknData = NtfTknData
     tknVerifyKey :: C.APublicVerifyKey,
     tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: TVar Word16
+    tknRegCode :: NtfRegCode
   }
 
 mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
 mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
   tknStatus <- newTVar NTRegistered
-  tknCronInterval <- newTVar 0
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode}
+
+-- data NtfSubscriptionsStore = NtfSubscriptionsStore
+
+-- { subscriptions :: TMap NtfSubsciptionId NtfSubsciption,
+--   activeSubscriptions :: TMap (SMPServer, NotifierId) NtfSubsciptionId
+-- }
+-- do
+-- subscriptions <- newTVar M.empty
+-- activeSubscriptions <- newTVar M.empty
+-- pure NtfSubscriptionsStore {subscriptions, activeSubscriptions}
 
 data NtfSubData = NtfSubData
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
+  { smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateSignKey,
     tokenId :: NtfTokenId,
     subStatus :: TVar NtfSubStatus
@@ -106,42 +109,24 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
       forM_ tIds $ \(regKey, tId') -> do
         TM.delete regKey tknRegs
         TM.delete tId' $ tokens st
-        void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
-removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
-removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
-  TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
-  where
-    removeReg regs =
-      TM.lookup k regs
-        >>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
-    k = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
+deleteNtfToken :: NtfStore -> NtfTokenId -> STM ()
 deleteNtfToken st tknId = do
-  void $
-    TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} ->
-      TM.lookup token regs $>>= \tIds ->
-        TM.delete (regKey tknVerifyKey) tIds
-          >> whenM (TM.null tIds) (TM.delete token regs) $> Just ()
-  deleteTokenSubs st tknId
+  TM.lookupDelete tknId (tokens st)
+    >>= mapM_
+      ( \NtfTknData {token, tknVerifyKey} ->
+          TM.lookup token regs
+            >>= mapM_
+              ( \tIds -> do
+                  TM.delete (regKey tknVerifyKey) tIds
+                  whenM (TM.null tIds) $ TM.delete token regs
+              )
+      )
   where
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes
 
-deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
-deleteTokenSubs st tknId = do
-  qs <-
-    TM.lookupDelete tknId (tokenSubscriptions st)
-      >>= mapM (readTVar >=> mapM deleteSub . S.toList)
-  pure $ maybe [] catMaybes qs
-  where
-    deleteSub subId = do
-      TM.lookupDelete subId (subscriptions st)
-        $>>= \NtfSubData {smpQueue} ->
-          TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
-
 getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
 getNtfSubscription st subId =
   TM.lookup subId (subscriptions st)
@@ -162,10 +147,10 @@ getActiveNtfToken st tknId =
     tStatus <- readTVar tknStatus
     pure $ if tStatus == NTActive then Just tkn else Nothing
 
-mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
-mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
+mkNtfSubData :: NewNtfEntity 'Subscription -> STM NtfSubData
+mkNtfSubData (NewNtfSub tokenId smpQueue notifierKey) = do
   subStatus <- newTVar NSNew
-  pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
+  pure NtfSubData {smpQueue, tokenId, subStatus, notifierKey}
 
 addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
 addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
@@ -182,12 +167,38 @@ addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
       -- return Nothing if subscription existed before
       pure $ Just ()
 
-deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
-deleteNtfSubscription st subId = do
-  TM.lookupDelete subId (subscriptions st)
-    >>= mapM_
-      ( \NtfSubData {smpQueue, tokenId} -> do
-          TM.delete smpQueue $ subscriptionLookup st
-          ts_ <- TM.lookup tokenId (tokenSubscriptions st)
-          forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
-      )
+-- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
+-- getNtfRec st ent entId = case ent of
+--   SToken -> NtfTkn <$$> TM.lookup entId (tokens st)
+--   SSubscription -> pure Nothing
+
+-- getNtfVerifyKey :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e, C.APublicVerifyKey))
+-- getNtfVerifyKey st ent entId =
+--   getNtfRec st ent entId >>= \case
+--     Just r@(NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
+--     Just r@(NtfSub NtfSubData {tokenId}) ->
+--       getNtfRec st SToken tokenId >>= \case
+--         Just (NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
+--         _ -> pure Nothing
+--     _ -> pure Nothing
+
+-- mkNtfSubsciption :: SMPQueueNtf -> NtfTokenId -> STM NtfSubsciption
+-- mkNtfSubsciption smpQueue tokenId = do
+--   subStatus <- newTVar NSNew
+--   pure NtfSubsciption {smpQueue, tokenId, subStatus}
+
+-- getNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM (Maybe NtfSubsciption)
+-- getNtfSub st subId = pure Nothing -- maybe (pure $ Left AUTH) (fmap Right . readTVar) . M.lookup subId . subscriptions =<< readTVar st
+
+-- getNtfSubViaSMPQueue :: NtfSubscriptionsStore -> SMPQueueNtf -> STM (Maybe NtfSubsciption)
+-- getNtfSubViaSMPQueue st smpQueue = pure Nothing
+
+-- -- replace keeping status
+-- updateNtfSub :: NtfSubscriptionsStore -> NtfSubsciption -> SMPQueueNtf -> NtfTokenId -> C.DhSecretX25519 -> STM (Maybe ())
+-- updateNtfSub st sub smpQueue tokenId dhSecret = pure Nothing
+
+-- addNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> NtfSubsciption -> STM (Maybe ())
+-- addNtfSub st subId sub = pure Nothing
+
+-- deleteNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM ()
+-- deleteNtfSub st subId = pure ()

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

@@ -1,227 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Server.StoreLog
-  ( StoreLog,
-    NtfStoreLogRecord (..),
-    readWriteNtfStore,
-    logCreateToken,
-    logTokenStatus,
-    logUpdateToken,
-    logTokenCron,
-    logDeleteToken,
-    logCreateSubscription,
-    logSubscriptionStatus,
-    logDeleteSubscription,
-    closeStoreLog,
-  )
-where
-
-import Control.Concurrent.STM
-import Control.Monad (void)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Word (Word16)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (NtfPrivateSignKey)
-import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (whenM)
-import System.Directory (doesFileExist, renameFile)
-import System.IO
-
-data NtfStoreLogRecord
-  = CreateToken NtfTknRec
-  | TokenStatus NtfTokenId NtfTknStatus
-  | UpdateToken NtfTokenId DeviceToken NtfRegCode
-  | TokenCron NtfTokenId Word16
-  | DeleteToken NtfTokenId
-  | CreateSubscription NtfSubRec
-  | SubscriptionStatus NtfSubscriptionId NtfSubStatus
-  | DeleteSubscription NtfSubscriptionId
-
-data NtfTknRec = NtfTknRec
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: Word16
-  }
-
-mkTknData :: NtfTknRec -> STM NtfTknData
-mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- newTVar status
-  tknCronInterval <- newTVar cronInt
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-mkTknRec :: NtfTknData -> STM NtfTknRec
-mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- readTVar status
-  tknCronInterval <- readTVar cronInt
-  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-data NtfSubRec = NtfSubRec
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateSignKey,
-    tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus
-  }
-
-mkSubData :: NtfSubRec -> STM NtfSubData
-mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- newTVar status
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-mkSubRec :: NtfSubData -> STM NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- readTVar status
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-instance StrEncoding NtfStoreLogRecord where
-  strEncode = \case
-    CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
-    TokenStatus tknId tknStatus -> strEncode (Str "TSTATUS", tknId, tknStatus)
-    UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
-    TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
-    DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
-    CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
-    SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
-    DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
-  strP =
-    A.choice
-      [ "TCREATE " *> (CreateToken <$> strP),
-        "TSTATUS " *> (TokenStatus <$> strP_ <*> strP),
-        "TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
-        "TCRON " *> (TokenCron <$> strP_ <*> strP),
-        "TDELETE " *> (DeleteToken <$> strP),
-        "SCREATE " *> (CreateSubscription <$> strP),
-        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
-        "SDELETE " *> (DeleteSubscription <$> strP)
-      ]
-
-instance StrEncoding NtfTknRec where
-  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} =
-    B.unwords
-      [ "tknId=" <> strEncode ntfTknId,
-        "token=" <> strEncode token,
-        "tokenStatus=" <> strEncode tknStatus,
-        "verifyKey=" <> strEncode tknVerifyKey,
-        "dhKeys=" <> strEncode tknDhKeys,
-        "dhSecret=" <> strEncode tknDhSecret,
-        "regCode=" <> strEncode tknRegCode,
-        "cron=" <> strEncode tknCronInterval
-      ]
-  strP = do
-    ntfTknId <- "tknId=" *> strP_
-    token <- "token=" *> strP_
-    tknStatus <- "tokenStatus=" *> strP_
-    tknVerifyKey <- "verifyKey=" *> strP_
-    tknDhKeys <- "dhKeys=" *> strP_
-    tknDhSecret <- "dhSecret=" *> strP_
-    tknRegCode <- "regCode=" *> strP_
-    tknCronInterval <- "cron=" *> strP
-    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
-    B.unwords
-      [ "subId=" <> strEncode ntfSubId,
-        "smpQueue=" <> strEncode smpQueue,
-        "notifierKey=" <> strEncode notifierKey,
-        "tknId=" <> strEncode tokenId,
-        "subStatus=" <> strEncode subStatus
-      ]
-  strP = do
-    ntfSubId <- "subId=" *> strP_
-    smpQueue <- "smpQueue=" *> strP_
-    notifierKey <- "notifierKey=" *> strP_
-    tokenId <- "tknId=" *> strP_
-    subStatus <- "subStatus=" *> strP
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
-logNtfStoreRecord = writeStoreLogRecord
-
-logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
-logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
-
-logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
-logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
-
-logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
-logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode
-
-logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
-logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
-
-logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
-logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
-
-logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
-logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
-
-logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
-logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
-
-logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
-logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
-
-readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
-readWriteNtfStore f st = do
-  whenM (doesFileExist f) $ do
-    readNtfStore f st
-    renameFile f $ f <> ".bak"
-  s <- openWriteStoreLog f
-  writeNtfStore s st
-  pure s
-
-readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
-  where
-    addNtfLogRecord s = case strDecode s of
-      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
-      Right lr -> atomically $ case lr of
-        CreateToken r@NtfTknRec {ntfTknId} -> do
-          tkn <- mkTknData r
-          addNtfToken st ntfTknId tkn
-        TokenStatus tknId status ->
-          getNtfToken st tknId
-            >>= mapM_ (\NtfTknData {tknStatus} -> writeTVar tknStatus status)
-        UpdateToken tknId token' tknRegCode ->
-          getNtfToken st tknId
-            >>= mapM_
-              ( \tkn@NtfTknData {tknStatus} -> do
-                  removeTokenRegistration st tkn
-                  writeTVar tknStatus NTRegistered
-                  addNtfToken st tknId tkn {token = token', tknRegCode}
-              )
-        TokenCron tknId cronInt ->
-          getNtfToken st tknId
-            >>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
-        DeleteToken tknId ->
-          void $ deleteNtfToken st tknId
-        CreateSubscription r@NtfSubRec {ntfSubId} -> do
-          sub <- mkSubData r
-          void $ addNtfSubscription st ntfSubId sub
-        SubscriptionStatus subId status ->
-          getNtfSubscription st subId
-            >>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
-        DeleteSubscription subId ->
-          deleteNtfSubscription st subId
-
-writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
-writeNtfStore s NtfStore {tokens, subscriptions} = do
-  atomically (readTVar tokens >>= mapM mkTknRec)
-    >>= mapM_ (writeStoreLogRecord s . CreateToken)
-  atomically (readTVar subscriptions >>= mapM mkSubRec)
-    >>= mapM_ (writeStoreLogRecord s . CreateSubscription)

src/Simplex/Messaging/Notifications/Transport.hs

@@ -1,13 +1,7 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Simplex.Messaging.Notifications.Transport where
 
 import Control.Monad.Except
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Version
 
@@ -17,56 +11,13 @@ ntfBlockSize = 512
 supportedNTFServerVRange :: VersionRange
 supportedNTFServerVRange = mkVersionRange 1 1
 
-data NtfServerHandshake = NtfServerHandshake
-  { ntfVersionRange :: VersionRange,
-    sessionId :: SessionId
-  }
-
-data NtfClientHandshake = NtfClientHandshake
-  { -- | agreed SMP notifications server protocol version
-    ntfVersion :: Version,
-    -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
-  }
-
-instance Encoding NtfServerHandshake where
-  smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
-    smpEncode (ntfVersionRange, sessionId)
-  smpP = do
-    (ntfVersionRange, sessionId) <- smpP
-    pure NtfServerHandshake {ntfVersionRange, sessionId}
-
-instance Encoding NtfClientHandshake where
-  smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
-  smpP = do
-    (ntfVersion, keyHash) <- smpP
-    pure NtfClientHandshake {ntfVersion, keyHash}
-
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c kh ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
-  getHandshake th >>= \case
-    NtfClientHandshake {ntfVersion, keyHash}
-      | keyHash /= kh ->
-        throwError $ TEHandshake IDENTITY
-      | ntfVersion `isCompatible` ntfVRange -> do
-        pure (th :: THandle c) {thVersion = ntfVersion}
-      | otherwise -> throwError $ TEHandshake VERSION
+ntfServerHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfServerHandshake c _ _ = pure $ ntfTHandle c
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfClientHandshake c keyHash ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
-  if sessionId /= sessId
-    then throwError TEBadSession
-    else case ntfVersionRange `compatibleVersion` ntfVRange of
-      Just (Compatible ntfVersion) -> do
-        sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
-        pure (th :: THandle c) {thVersion = ntfVersion}
-      Nothing -> throwError $ TEHandshake VERSION
+ntfClientHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfClientHandshake c _ _ = pure $ ntfTHandle c
 
 ntfTHandle :: Transport c => c -> THandle c
-ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}
+ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}

src/Simplex/Messaging/Notifications/Types.hs

@@ -1,197 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Types where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time (UTCTime)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
-import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..))
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
-import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
-
-data NtfTknAction
-  = NTARegister
-  | NTAVerify NtfRegCode -- code to verify token
-  | NTACheck
-  | NTADelete
-  deriving (Show)
-
-instance Encoding NtfTknAction where
-  smpEncode = \case
-    NTARegister -> "R"
-    NTAVerify code -> smpEncode ('V', code)
-    NTACheck -> "C"
-    NTADelete -> "D"
-  smpP =
-    A.anyChar >>= \case
-      'R' -> pure NTARegister
-      'V' -> NTAVerify <$> smpP
-      'C' -> pure NTACheck
-      'D' -> pure NTADelete
-      _ -> fail "bad NtfTknAction"
-
-instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfTknAction where toField = toField . smpEncode
-
-data NtfToken = NtfToken
-  { deviceToken :: DeviceToken,
-    ntfServer :: NtfServer,
-    ntfTokenId :: Maybe NtfTokenId,
-    -- | key used by the ntf server to verify transmissions
-    ntfPubKey :: C.APublicVerifyKey,
-    -- | key used by the ntf client to sign transmissions
-    ntfPrivKey :: C.APrivateSignKey,
-    -- | client's DH keys (to repeat registration if necessary)
-    ntfDhKeys :: C.KeyPair 'C.X25519,
-    -- | shared DH secret used to encrypt/decrypt notifications e2e
-    ntfDhSecret :: Maybe C.DhSecretX25519,
-    -- | token status
-    ntfTknStatus :: NtfTknStatus,
-    -- | pending token action and the earliest time
-    ntfTknAction :: Maybe NtfTknAction,
-    ntfMode :: NotificationsMode
-  }
-  deriving (Show)
-
-newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
-newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
-  NtfToken
-    { deviceToken,
-      ntfServer,
-      ntfTokenId = Nothing,
-      ntfPubKey,
-      ntfPrivKey,
-      ntfDhKeys,
-      ntfDhSecret = Nothing,
-      ntfTknStatus = NTNew,
-      ntfTknAction = Just NTARegister,
-      ntfMode
-    }
-
-data NtfSubAction = NtfSubNTFAction NtfSubNTFAction | NtfSubSMPAction NtfSubSMPAction
-  deriving (Show)
-
-isDeleteNtfSubAction :: NtfSubAction -> Bool
-isDeleteNtfSubAction = \case
-  NtfSubNTFAction a -> case a of
-    NSACreate -> False
-    NSACheck -> False
-    NSADelete -> True
-    NSARotate -> True
-  NtfSubSMPAction a -> case a of
-    NSASmpKey -> False
-    NSASmpDelete -> True
-
-type NtfActionTs = UTCTime
-
-data NtfSubNTFAction
-  = NSACreate
-  | NSACheck
-  | NSADelete
-  | NSARotate
-  deriving (Show)
-
-instance Encoding NtfSubNTFAction where
-  smpEncode = \case
-    NSACreate -> "N"
-    NSACheck -> "C"
-    NSADelete -> "D"
-    NSARotate -> "R"
-  smpP =
-    A.anyChar >>= \case
-      'N' -> pure NSACreate
-      'C' -> pure NSACheck
-      'D' -> pure NSADelete
-      'R' -> pure NSARotate
-      _ -> fail "bad NtfSubNTFAction"
-
-instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfSubNTFAction where toField = toField . smpEncode
-
-data NtfSubSMPAction
-  = NSASmpKey
-  | NSASmpDelete
-  deriving (Show)
-
-instance Encoding NtfSubSMPAction where
-  smpEncode = \case
-    NSASmpKey -> "K"
-    NSASmpDelete -> "D"
-  smpP =
-    A.anyChar >>= \case
-      'K' -> pure NSASmpKey
-      'D' -> pure NSASmpDelete
-      _ -> fail "bad NtfSubSMPAction"
-
-instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfSubSMPAction where toField = toField . smpEncode
-
-data NtfAgentSubStatus
-  = -- | subscription started
-    NASNew
-  | -- | state after NKEY - notifier ID is assigned to queue on SMP server
-    NASKey
-  | -- | state after SNEW - subscription created on notification server
-    NASCreated NtfSubStatus
-  | -- | state after SDEL (subscription is deleted on notification server)
-    NASOff
-  | -- | state after NDEL (notifier credentials are deleted on SMP server)
-    -- Can only exist transiently - if subscription record was updated by notification supervisor mid worker operation,
-    -- and hence got updated instead of being fully deleted in the database post operation by worker
-    NASDeleted
-  deriving (Eq, Show)
-
-instance Encoding NtfAgentSubStatus where
-  smpEncode = \case
-    NASNew -> "NEW"
-    NASKey -> "KEY"
-    NASCreated status -> "CREATED " <> smpEncode status
-    NASOff -> "OFF"
-    NASDeleted -> "DELETED"
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NASNew
-      "KEY" -> pure NASKey
-      "CREATED" -> do
-        _ <- A.space
-        NASCreated <$> smpP
-      "OFF" -> pure NASOff
-      "DELETED" -> pure NASDeleted
-      _ -> fail "bad NtfAgentSubStatus"
-
-instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
-
-instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
-
-data NtfSubscription = NtfSubscription
-  { connId :: ConnId,
-    smpServer :: SMPServer,
-    ntfQueueId :: Maybe NotifierId,
-    ntfServer :: NtfServer,
-    ntfSubId :: Maybe NtfSubscriptionId,
-    ntfSubStatus :: NtfAgentSubStatus
-  }
-  deriving (Show)
-
-newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> NtfSubscription
-newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus =
-  NtfSubscription
-    { connId,
-      smpServer,
-      ntfQueueId,
-      ntfServer,
-      ntfSubId = Nothing,
-      ntfSubStatus
-    }

src/Simplex/Messaging/Parsers.hs

@@ -118,7 +118,6 @@ taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.TaggedObject "type" "data",
-      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
@@ -129,7 +128,6 @@ singleFieldJSON :: (String -> String) -> J.Options
 singleFieldJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.ObjectWithSingleField,
-      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
       J.nullaryToObject = True,

src/Simplex/Messaging/Protocol.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
@@ -17,13 +16,9 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-{-# HLINT ignore "Use newtype instead of data" #-}
-
 -- |
 -- Module      : Simplex.Messaging.ProtocolEncoding
 -- Copyright   : (c) simplex.chat
@@ -38,7 +33,8 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Protocol
   ( -- * SMP protocol parameters
-    supportedSMPClientVRange,
+    smpClientVersion,
+    smpClientVRange,
     maxMessageLength,
     e2eEncConfirmationLength,
     e2eEncMessageLength,
@@ -63,18 +59,9 @@ module Simplex.Messaging.Protocol
     ClientMessage (..),
     PrivHeader (..),
     Protocol (..),
-    ProtocolType (..),
-    AProtocolType (..),
-    ProtocolTypeI (..),
     ProtocolServer (..),
-    ProtoServer,
     SMPServer,
     pattern SMPServer,
-    SMPServerWithAuth,
-    NtfServer,
-    pattern NtfServer,
-    ProtoServerWithAuth (..),
-    BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -89,22 +76,9 @@ module Simplex.Messaging.Protocol
     SndPublicVerifyKey,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
-    RcvNtfPublicDhKey,
-    RcvNtfDhSecret,
-    Message (..),
-    RcvMessage (..),
     MsgId,
     MsgBody,
-    MaxMessageLen,
-    MaxRcvMessageLen,
-    EncRcvMsgBody (..),
-    RcvMsgBody (..),
-    ClientRcvMsgBody (..),
-    EncNMsgMeta,
-    SMPMsgMeta (..),
-    NMsgMeta (..),
     MsgFlags (..),
-    rcvMessageMeta,
     noMsgFlags,
 
     -- * Parse and serialize
@@ -113,14 +87,6 @@ module Simplex.Messaging.Protocol
     encodeTransmission,
     transmissionP,
     _smpP,
-    encodeRcvMsgBody,
-    clientRcvMsgBodyP,
-    legacyEncodeServer,
-    legacyServerP,
-    legacyStrEncodeServer,
-    sameSrvAddr,
-    sameSrvAddr',
-    noAuthSrv,
 
     -- * TCP transport functions
     tPut,
@@ -134,23 +100,18 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad.Except
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isPrint, isSpace)
-import Data.Functor (($>))
 import Data.Kind
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as L
-import Data.Maybe (isJust, isNothing)
+import Data.Maybe (isNothing)
 import Data.String
-import Data.Time.Clock.System (SystemTime (..))
+import Data.Time.Clock.System (SystemTime)
 import Data.Type.Equality
 import GHC.Generics (Generic)
-import GHC.TypeLits (type (+))
 import Generic.Random (genericArbitraryU)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
@@ -158,25 +119,19 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
-currentSMPClientVersion :: Version
-currentSMPClientVersion = 2
+smpClientVersion :: Version
+smpClientVersion = 1
 
-supportedSMPClientVRange :: VersionRange
-supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
+smpClientVRange :: VersionRange
+smpClientVRange = mkVersionRange 1 smpClientVersion
 
 maxMessageLength :: Int
 maxMessageLength = 16088
 
-type MaxMessageLen = 16088
-
--- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
-type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
-
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
 e2eEncConfirmationLength = 15936
@@ -257,11 +212,10 @@ type EntityId = ByteString
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient
+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
-  NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
-  NDEL :: Command Recipient
+  NKEY :: NtfPublicVerifyKey -> Command Recipient
   GET :: Command Recipient
   -- ACK v1 has to be supported for encoding/decoding
   -- ACK :: Command Recipient
@@ -283,159 +237,20 @@ deriving instance Eq (Command p)
 data BrokerMsg where
   -- SMP broker messages (responses, client messages, notifications)
   IDS :: QueueIdsKeys -> BrokerMsg
-  -- MSG v1/2 has to be supported for encoding/decoding
-  -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
-  -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
-  MSG :: RcvMessage -> BrokerMsg
-  NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
-  NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
+  -- MSG v1 has to be supported for encoding/decoding
+  -- MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  MSG :: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
+  NID :: NotifierId -> BrokerMsg
+  NMSG :: BrokerMsg
   END :: BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
   deriving (Eq, Show)
 
-data RcvMessage = RcvMessage
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
-  }
+newtype MsgFlags = MsgFlags {notification :: Bool}
   deriving (Eq, Show)
 
--- | received message without server/recipient encryption
-data Message
-  = Message
-      { msgId :: MsgId,
-        msgTs :: SystemTime,
-        msgFlags :: MsgFlags,
-        msgBody :: C.MaxLenBS MaxMessageLen
-      }
-  | MessageQuota
-      { msgId :: MsgId,
-        msgTs :: SystemTime
-      }
-
-instance StrEncoding RcvMessage where
-  strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
-    B.unwords
-      [ strEncode msgId,
-        strEncode msgTs,
-        "flags=" <> strEncode msgFlags,
-        strEncode body
-      ]
-  strP = do
-    msgId <- strP_
-    msgTs <- strP_
-    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-    msgBody <- EncRcvMsgBody <$> strP
-    pure RcvMessage {msgId, msgTs, msgFlags, msgBody}
-
-newtype EncRcvMsgBody = EncRcvMsgBody ByteString
-  deriving (Eq, Show)
-
-data RcvMsgBody
-  = RcvMsgBody
-      { msgTs :: SystemTime,
-        msgFlags :: MsgFlags,
-        msgBody :: C.MaxLenBS MaxMessageLen
-      }
-  | RcvMsgQuota
-      { msgTs :: SystemTime
-      }
-
-msgQuotaTag :: ByteString
-msgQuotaTag = "QUOTA"
-
-encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
-encodeRcvMsgBody = \case
-  RcvMsgBody {msgTs, msgFlags, msgBody} ->
-    let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
-     in C.appendMaxLenBS rcvMeta msgBody
-  RcvMsgQuota {msgTs} ->
-    C.unsafeMaxLenBS $ msgQuotaTag <> " " <> smpEncode msgTs
-
-data ClientRcvMsgBody
-  = ClientRcvMsgBody
-      { msgTs :: SystemTime,
-        msgFlags :: MsgFlags,
-        msgBody :: ByteString
-      }
-  | ClientRcvMsgQuota
-      { msgTs :: SystemTime
-      }
-
-clientRcvMsgBodyP :: Parser ClientRcvMsgBody
-clientRcvMsgBodyP = msgQuotaP <|> msgBodyP
-  where
-    msgQuotaP = A.string msgQuotaTag *> (ClientRcvMsgQuota <$> _smpP)
-    msgBodyP = do
-      msgTs <- smpP
-      msgFlags <- smpP
-      Tail msgBody <- _smpP
-      pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
-
-instance StrEncoding Message where
-  strEncode = \case
-    Message {msgId, msgTs, msgFlags, msgBody} ->
-      B.unwords
-        [ strEncode msgId,
-          strEncode msgTs,
-          "flags=" <> strEncode msgFlags,
-          strEncode msgBody
-        ]
-    MessageQuota {msgId, msgTs} ->
-      B.unwords
-        [ strEncode msgId,
-          strEncode msgTs,
-          "quota"
-        ]
-  strP = do
-    msgId <- strP_
-    msgTs <- strP_
-    msgQuotaP msgId msgTs <|> msgP msgId msgTs
-    where
-      msgQuotaP msgId msgTs = "quota" $> MessageQuota {msgId, msgTs}
-      msgP msgId msgTs = do
-        msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-        msgBody <- strP
-        pure Message {msgId, msgTs, msgFlags, msgBody}
-
-type EncNMsgMeta = ByteString
-
-data SMPMsgMeta = SMPMsgMeta
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags
-  }
-  deriving (Show)
-
-rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
-rcvMessageMeta msgId = \case
-  ClientRcvMsgBody {msgTs, msgFlags} -> SMPMsgMeta {msgId, msgTs, msgFlags}
-  ClientRcvMsgQuota {msgTs} -> SMPMsgMeta {msgId, msgTs, msgFlags = noMsgFlags}
-
-data NMsgMeta = NMsgMeta
-  { msgId :: MsgId,
-    msgTs :: SystemTime
-  }
-  deriving (Show)
-
-instance Encoding NMsgMeta where
-  smpEncode NMsgMeta {msgId, msgTs} =
-    smpEncode (msgId, msgTs)
-  smpP = do
-    -- Tail here is to allow extension in the future clients/servers
-    (msgId, msgTs, Tail _) <- smpP
-    pure NMsgMeta {msgId, msgTs}
-
--- it must be data for correct JSON encoding
-data MsgFlags = MsgFlags {notification :: Bool}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions
-
--- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
 instance Encoding MsgFlags where
   smpEncode MsgFlags {notification} = smpEncode notification
   smpP = do
@@ -458,7 +273,6 @@ data CommandTag (p :: Party) where
   SUB_ :: CommandTag Recipient
   KEY_ :: CommandTag Recipient
   NKEY_ :: CommandTag Recipient
-  NDEL_ :: CommandTag Recipient
   GET_ :: CommandTag Recipient
   ACK_ :: CommandTag Recipient
   OFF_ :: CommandTag Recipient
@@ -498,7 +312,6 @@ instance PartyI p => Encoding (CommandTag p) where
     SUB_ -> "SUB"
     KEY_ -> "KEY"
     NKEY_ -> "NKEY"
-    NDEL_ -> "NDEL"
     GET_ -> "GET"
     ACK_ -> "ACK"
     OFF_ -> "OFF"
@@ -514,7 +327,6 @@ instance ProtocolMsgTag CmdTag where
     "SUB" -> Just $ CT SRecipient SUB_
     "KEY" -> Just $ CT SRecipient KEY_
     "NKEY" -> Just $ CT SRecipient NKEY_
-    "NDEL" -> Just $ CT SRecipient NDEL_
     "GET" -> Just $ CT SRecipient GET_
     "ACK" -> Just $ CT SRecipient ACK_
     "OFF" -> Just $ CT SRecipient OFF_
@@ -601,201 +413,44 @@ instance Encoding ClientMessage where
   smpEncode (ClientMessage h msg) = smpEncode h <> msg
   smpP = ClientMessage <$> smpP <*> A.takeByteString
 
-type SMPServer = ProtocolServer 'PSMP
+type SMPServer = ProtocolServer
 
-pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
-pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
+pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer
+pattern SMPServer host port keyHash = ProtocolServer host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
-type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
-
-type NtfServer = ProtocolServer 'PNTF
-
-pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
-pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
-
-{-# COMPLETE NtfServer #-}
-
-sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
-sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
-{-# INLINE sameSrvAddr' #-}
-
-sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
-sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
-{-# INLINE sameSrvAddr #-}
-
-data ProtocolType = PSMP | PNTF
-  deriving (Eq, Ord, Show)
-
-instance StrEncoding ProtocolType where
-  strEncode = \case
-    PSMP -> "smp"
-    PNTF -> "ntf"
-  strP =
-    A.takeTill (\c -> c == ':' || c == ' ') >>= \case
-      "smp" -> pure PSMP
-      "ntf" -> pure PNTF
-      _ -> fail "bad ProtocolType"
-
-data SProtocolType (p :: ProtocolType) where
-  SPSMP :: SProtocolType 'PSMP
-  SPNTF :: SProtocolType 'PNTF
-
-deriving instance Eq (SProtocolType p)
-
-deriving instance Ord (SProtocolType p)
-
-deriving instance Show (SProtocolType p)
-
-data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
-
-deriving instance Show AProtocolType
-
-instance Eq AProtocolType where
-  AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
-
-instance TestEquality SProtocolType where
-  testEquality SPSMP SPSMP = Just Refl
-  testEquality SPNTF SPNTF = Just Refl
-  testEquality _ _ = Nothing
-
-protocolType :: SProtocolType p -> ProtocolType
-protocolType = \case
-  SPSMP -> PSMP
-  SPNTF -> PNTF
-
-aProtocolType :: ProtocolType -> AProtocolType
-aProtocolType = \case
-  PSMP -> AProtocolType SPSMP
-  PNTF -> AProtocolType SPNTF
-
-instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
-  strEncode = strEncode . protocolType
-  strP = (\(AProtocolType p) -> checkProtocolType p) <$?> strP
-
-instance StrEncoding AProtocolType where
-  strEncode (AProtocolType p) = strEncode p
-  strP = aProtocolType <$> strP
-
-instance ToJSON AProtocolType where
-  toEncoding = strToJEncoding
-  toJSON = strToJSON
-
-checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
-checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
-  Just Refl -> Right p
-  Nothing -> Left "bad ProtocolType"
-
-class ProtocolTypeI (p :: ProtocolType) where
-  protocolTypeI :: SProtocolType p
-
-instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP
-
-instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
-
--- | server location and transport key digest (hash).
-data ProtocolServer p = ProtocolServer
-  { scheme :: SProtocolType p,
-    host :: NonEmpty TransportHost,
+-- | SMP server location and transport key digest (hash).
+data ProtocolServer = ProtocolServer
+  { host :: HostName,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
   deriving (Eq, Ord, Show)
 
-instance ProtocolTypeI p => IsString (ProtocolServer p) where
+instance IsString ProtocolServer where
   fromString = parseString strDecode
 
-instance ProtocolTypeI p => Encoding (ProtocolServer p) where
+instance Encoding ProtocolServer where
   smpEncode ProtocolServer {host, port, keyHash} =
     smpEncode (host, port, keyHash)
   smpP = do
     (host, port, keyHash) <- smpP
-    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}
+    pure ProtocolServer {host, port, keyHash}
 
-instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
-  strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncodeServer scheme (strEncode host) port keyHash Nothing
-  strP =
-    serverStrP >>= \case
-      (srv, Nothing) -> pure srv
-      _ -> fail "ProtocolServer with basic auth not allowed"
+instance StrEncoding ProtocolServer where
+  strEncode ProtocolServer {host, port, keyHash} =
+    "smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
+  strP = do
+    _ <- "smp://"
+    keyHash <- strP <* A.char '@'
+    SrvLoc host port <- strP
+    pure ProtocolServer {host, port, keyHash}
 
-instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
+instance ToJSON ProtocolServer where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
-  deriving (Eq, Show)
-
-instance IsString BasicAuth where fromString = BasicAuth . B.pack
-
-instance Encoding BasicAuth where
-  smpEncode (BasicAuth s) = smpEncode s
-  smpP = basicAuth <$?> smpP
-
-instance StrEncoding BasicAuth where
-  strEncode (BasicAuth s) = s
-  strP = basicAuth <$?> A.takeWhile1 (/= '@')
-
-basicAuth :: ByteString -> Either String BasicAuth
-basicAuth s
-  | B.all valid s = Right $ BasicAuth s
-  | otherwise = Left "invalid character in BasicAuth"
-  where
-    valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
-
-data ProtoServerWithAuth p = ProtoServerWithAuth (ProtocolServer p) (Maybe BasicAuth)
-  deriving (Show)
-
-instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
-  fromString = parseString strDecode
-
-instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
-  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
-    strEncodeServer scheme (strEncode host) port keyHash auth_
-  strP = uncurry ProtoServerWithAuth <$> serverStrP
-
-instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
-  parseJSON = strParseJSON "ProtoServerWithAuth"
-
-noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
-noAuthSrv srv = ProtoServerWithAuth srv Nothing
-
-legacyEncodeServer :: ProtocolServer p -> ByteString
-legacyEncodeServer ProtocolServer {host, port, keyHash} =
-  smpEncode (L.head host, port, keyHash)
-
-legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
-legacyServerP = do
-  (h, port, keyHash) <- smpP
-  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
-
-legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
-legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
-
-strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
-strEncodeServer scheme host port keyHash auth_ =
-  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
-  where
-    portStr = B.pack $ if null port then "" else ':' : port
-
-serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
-serverStrP = do
-  scheme <- strP <* "://"
-  keyHash <- strP
-  auth_ <- optional $ A.char ':' *> strP
-  TransportHosts host <- A.char '@' *> strP
-  port <- portP <|> pure ""
-  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
-  where
-    portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
-
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
 
@@ -804,7 +459,7 @@ instance StrEncoding SrvLoc where
   strP = SrvLoc <$> host <*> (port <|> pure "")
     where
       host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
 
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
@@ -857,12 +512,6 @@ type NtfPrivateSignKey = C.APrivateSignKey
 -- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
 type NtfPublicVerifyKey = C.APublicVerifyKey
 
--- | Public key used for DH exchange to encrypt notification metadata from server to recipient
-type RcvNtfPublicDhKey = C.PublicKeyX25519
-
--- | DH Secret used to encrypt notification metadata from server to recipient
-type RcvNtfDhSecret = C.DhSecretX25519
-
 -- | SMP message server ID.
 type MsgId = ByteString
 
@@ -883,12 +532,12 @@ data ErrorType
     QUOTA
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
-  | -- | sent message is too large (> maxMessageLength = 16088 bytes)
+  | -- | sent message is too large (> maxMessageLength = 16078 bytes)
     LARGE_MSG
   | -- | internal server error
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
-    DUPLICATE_ -- not part of SMP protocol, used internally
+    DUPLICATE_ -- TODO remove, not part of SMP protocol
   deriving (Eq, Generic, Read, Show)
 
 instance ToJSON ErrorType where
@@ -939,18 +588,14 @@ transmissionP = do
       command <- A.takeByteString
       pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
 
-class (ProtocolEncoding msg, ProtocolEncoding (ProtoCommand msg), Show msg) => Protocol msg where
-  type ProtoCommand msg = cmd | cmd -> msg
-  type ProtoType msg = (sch :: ProtocolType) | sch -> msg
+class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
+  type ProtocolCommand msg = cmd | cmd -> msg
   protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-  protocolPing :: ProtoCommand msg
+  protocolPing :: ProtocolCommand msg
   protocolError :: msg -> Maybe ErrorType
 
-type ProtoServer msg = ProtocolServer (ProtoType msg)
-
 instance Protocol BrokerMsg where
-  type ProtoCommand BrokerMsg = Cmd
-  type ProtoType BrokerMsg = 'PSMP
+  type ProtocolCommand BrokerMsg = Cmd
   protocolClientHandshake = smpClientHandshake
   protocolPing = Cmd SSender PING
   protocolError = \case
@@ -966,17 +611,10 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
 instance PartyI p => ProtocolEncoding (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol v = \case
-    NEW rKey dhKey auth_ -> case auth_ of
-      Just auth
-        | v >= 5 -> new <> e ('A', auth)
-        | otherwise -> new
-      _ -> new
-      where
-        new = e (NEW_, ' ', rKey, dhKey)
+    NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
-    NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
-    NDEL -> e NDEL_
+    NKEY k -> e (NKEY_, ' ', k)
     GET -> e GET_
     ACK msgId
       | v == 1 -> e ACK_
@@ -1020,15 +658,10 @@ instance ProtocolEncoding Cmd where
   protocolP v = \case
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
-        NEW_
-          | v >= 5 -> new <*> optional (A.char 'A' *> smpP)
-          | otherwise -> new <*> pure Nothing
-          where
-            new = NEW <$> _smpP <*> smpP
+        NEW_ -> NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
-        NKEY_ -> NKEY <$> _smpP <*> smpP
-        NDEL_ -> pure NDEL
+        NKEY_ -> NKEY <$> _smpP
         GET_ -> pure GET
         ACK_
           | v == 1 -> pure $ ACK ""
@@ -1038,7 +671,7 @@ instance ProtocolEncoding Cmd where
     CT SSender tag ->
       Cmd SSender <$> case tag of
         SEND_
-          | v == 1 -> SEND noMsgFlags <$> (unTail <$> _smpP)
+          | v == 1 -> SEND <$> pure noMsgFlags <*> (unTail <$> _smpP)
           | otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
         PING_ -> pure PING
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
@@ -1049,12 +682,11 @@ instance ProtocolEncoding BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol v = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
-    MSG RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body}
-      | v == 1 -> e (MSG_, ' ', msgId, msgTs, Tail body)
-      | v == 2 -> e (MSG_, ' ', msgId, msgTs, msgFlags, ' ', Tail body)
-      | otherwise -> e (MSG_, ' ', msgId, Tail body)
-    NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
-    NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
+    MSG msgId ts flags msgBody
+      | v == 1 -> e (MSG_, ' ', msgId, ts, Tail msgBody)
+      | otherwise -> e (MSG_, ' ', msgId, ts, flags, ' ', Tail msgBody)
+    NID nId -> e (NID_, ' ', nId)
+    NMSG -> e NMSG_
     END -> e END_
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
@@ -1064,17 +696,12 @@ instance ProtocolEncoding BrokerMsg where
       e = smpEncode
 
   protocolP v = \case
-    MSG_ -> do
-      msgId <- _smpP
-      MSG <$> case v of
-        1 -> RcvMessage msgId <$> smpP <*> pure noMsgFlags <*> bodyP
-        2 -> RcvMessage msgId <$> smpP <*> smpP <*> (A.space *> bodyP)
-        _ -> RcvMessage msgId (MkSystemTime 0 0) noMsgFlags <$> bodyP
-      where
-        bodyP = EncRcvMsgBody . unTail <$> smpP
+    MSG_
+      | v == 1 -> MSG <$> _smpP <*> smpP <*> pure noMsgFlags <*> (unTail <$> smpP)
+      | otherwise -> MSG <$> _smpP <*> smpP <*> smpP <*> (unTail <$> _smpP)
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
-    NID_ -> NID <$> _smpP <*> smpP
-    NMSG_ -> NMSG <$> _smpP <*> smpP
+    NID_ -> NID <$> _smpP
+    NMSG_ -> pure NMSG
     END_ -> pure END
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
@@ -1160,58 +787,20 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
-tPut th trs
-  | batch th = tPutBatch [] $ L.map tEncode trs
-  | otherwise = forM (L.toList trs) $ tPutLog . tEncode
-  where
-    tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO [Either TransportError ()]
-    tPutBatch rs ts = do
-      let (n, s, ts_) = encodeBatch 0 "" ts
-      r <- if n == 0 then largeMsg else replicate n <$> tPutLog (lenEncode n `B.cons` s)
-      let rs' = rs <> r
-      case ts_ of
-        Just ts' -> tPutBatch rs' ts'
-        _ -> pure rs'
-    largeMsg = putStrLn "tPut error: large message" >> pure [Left TELargeMsg]
-    tPutLog s = do
-      r <- tPutBlock th s
-      case r of
-        Left e -> putStrLn ("tPut error: " <> show e)
-        _ -> pure ()
-      pure r
-    encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
-    encodeBatch n s ts@(t :| ts_)
-      | n == 255 = (n, s, Just ts)
-      | otherwise =
-        let s' = s <> smpEncode (Large t)
-            n' = n + 1
-         in if B.length s' > blockSize th - 1 -- one byte is reserved for the number of messages in the batch
-              then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
-              else case L.nonEmpty ts_ of
-                Just ts' -> encodeBatch n' s' ts'
-                _ -> (n', s', Nothing)
-    tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
+tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
+tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
 
 encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
 encodeTransmission v sessionId (CorrId corrId, queueId, command) =
   smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
-tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
-tGetParse th
-  | batch th = either ((:| []) . Left) id <$> runExceptT getBatch
-  | otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
-  where
-    getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
-    getBatch = do
-      s <- ExceptT $ tGetBlock th
-      ts <- liftEither $ parse smpP TEBadBlock s
-      pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
+tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
+tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
-tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
+tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
+tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= decodeParseValidate
   where
     decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case

src/Simplex/Messaging/Server.hs

@@ -6,8 +6,8 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -40,43 +40,36 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
-import Data.Bifunctor (first)
-import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.List (intercalate)
-import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing)
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
+import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
-import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding (Encoding (smpEncode))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.Server.MsgStore.STM
+import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
-import System.Exit (exitFailure)
-import System.IO (hPutStrLn)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
@@ -87,7 +80,7 @@ import UnliftIO.STM
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
-runSMPServer :: ServerConfig -> IO ()
+runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m ()
 runSMPServer cfg = do
   started <- newEmptyTMVarIO
   runSMPServerBlocking started cfg
@@ -96,27 +89,25 @@ runSMPServer cfg = do
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)
+runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
+runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
 
-type M a = ReaderT Env IO a
-
-smpServer :: TMVar Bool -> ServerConfig -> M ()
-smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
+smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m ()
+smpServer started = do
   s <- asks server
+  cfg@ServerConfig {transports} <- asks config
   restoreServerMessages
-  restoreServerStats
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
       map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
     )
-    `finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
+    `finally` (withLog closeStoreLog >> saveServerMessages)
   where
-    runServer :: (ServiceName, ATransport) -> M ()
+    runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
+      runTransportServer started tcpPort serverParams (runClient t)
 
     serverThread ::
       forall s.
@@ -124,12 +115,12 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
       (Server -> TBQueue (QueueId, Client)) ->
       (Server -> TMap QueueId Client) ->
       (Client -> TMap QueueId s) ->
-      (s -> IO ()) ->
-      M ()
+      (s -> m ()) ->
+      m ()
     serverThread s subQ subs clientSubs unsub = forever $ do
       atomically updateSubscribers
         $>>= endPreviousSubscriptions
-        >>= liftIO . mapM_ unsub
+        >>= mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
@@ -141,17 +132,17 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
                     yes <- readTVar $ connected c'
                     pure $ if yes then Just (qId, c') else Nothing
           TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
-        endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
+        endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
         endPreviousSubscriptions (qId, c) = do
           void . forkIO . atomically $
-            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
+            writeTBQueue (sndQ c) (CorrId "", qId, END)
           atomically $ TM.lookupDelete qId (clientSubs c)
 
-    expireMessagesThread_ :: ServerConfig -> [M ()]
+    expireMessagesThread_ :: ServerConfig -> [m ()]
     expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
     expireMessagesThread_ _ = []
 
-    expireMessages :: ExpirationConfig -> M ()
+    expireMessages :: ExpirationConfig -> m ()
     expireMessages expCfg = do
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
@@ -164,57 +155,39 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
           atomically (getMsgQueue ms rId quota)
             >>= atomically . (`deleteExpiredMsgs` old)
 
-    serverStatsThread_ :: ServerConfig -> [M ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
-      [logServerStats logStatsStartTime interval serverStatsLogFile]
+    serverStatsThread_ :: ServerConfig -> [m ()]
+    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime} =
+      [logServerStats logStatsStartTime interval]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> FilePath -> M ()
-    logServerStats startAt logInterval statsFilePath = do
+    logServerStats :: Int -> Int -> m ()
+    logServerStats startAt logInterval = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
+      logInfo $ "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
       threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
       let interval = 1000000 * logInterval
-      withFile statsFilePath AppendMode $ \h -> liftIO $ do
-        hSetBuffering h LineBuffering
-        forever $ do
-          ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          qCreated' <- atomically $ swapTVar qCreated 0
-          qSecured' <- atomically $ swapTVar qSecured 0
-          qDeleted' <- atomically $ swapTVar qDeleted 0
-          msgSent' <- atomically $ swapTVar msgSent 0
-          msgRecv' <- atomically $ swapTVar msgRecv 0
-          ps <- atomically $ periodStatCounts activeQueues ts
-          msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
-          msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
-          psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
-          qCount' <- readTVarIO qCount
-          msgCount' <- readTVarIO msgCount
-          hPutStrLn h $
-            intercalate
-              ","
-              [ iso8601Show $ utctDay fromTime',
-                show qCreated',
-                show qSecured',
-                show qDeleted',
-                show msgSent',
-                show msgRecv',
-                dayCount ps,
-                weekCount ps,
-                monthCount ps,
-                show msgSentNtf',
-                show msgRecvNtf',
-                dayCount psNtf,
-                weekCount psNtf,
-                monthCount psNtf,
-                show qCount',
-                show msgCount'
-              ]
-          threadDelay interval
+      forever $ do
+        ts <- liftIO getCurrentTime
+        fromTime' <- atomically $ swapTVar fromTime ts
+        qCreated' <- atomically $ swapTVar qCreated 0
+        qSecured' <- atomically $ swapTVar qSecured 0
+        qDeleted' <- atomically $ swapTVar qDeleted 0
+        msgSent' <- atomically $ swapTVar msgSent 0
+        msgRecv' <- atomically $ swapTVar msgRecv 0
+        let day = utctDay ts
+            (_, wDay) = mondayStartWeek day
+            MonthDay _ mDay = day
+        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
+          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
+        logInfo . T.pack $ intercalate "," [show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
+        threadDelay interval
+      where
+        periodCount :: Int -> TVar (Set RecipientId) -> STM String
+        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
+        periodCount _ _ = pure ""
 
-    runClient :: Transport c => TProxy c -> c -> M ()
+    runClient :: Transport c => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
       smpVRange <- asks $ smpServerVRange . config
@@ -222,24 +195,24 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
         Right th -> runClientTransport th
         Left _ -> pure ()
 
-runClientTransport :: Transport c => THandle c -> M ()
-runClientTransport th@THandle {thVersion, sessionId} = do
+runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
+runClientTransport th@THandle {sessionId} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
-  c <- atomically $ newClient q thVersion sessionId ts
+  c <- atomically $ newClient q sessionId ts
   s <- asks server
   expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
+  raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
     `finally` clientDisconnected c
   where
-    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th c activeAt expCfg]
+    disconnectThread_ c (Just expCfg) = [disconnectTransport th c activeAt expCfg]
     disconnectThread_ _ _ = []
 
-clientDisconnected :: Client -> M ()
+clientDisconnected :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
 clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
-  liftIO $ mapM_ cancelSub subs
+  mapM_ cancelSub subs
   atomically $ writeTVar subscriptions M.empty
   cs <- asks $ subscribers . server
   atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
@@ -252,43 +225,34 @@ clientDisconnected c@Client {subscriptions, connected} = do
 sameClientSession :: Client -> Client -> Bool
 sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
-cancelSub :: TVar Sub -> IO ()
+cancelSub :: MonadUnliftIO m => TVar Sub -> m ()
 cancelSub sub =
   readTVarIO sub >>= \case
     Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
     _ -> return ()
 
-receive :: Transport c => THandle c -> Client -> M ()
+receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
 receive th Client {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- L.toList <$> tGet th
+  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
   atomically . writeTVar activeAt =<< liftIO getSystemTime
-  as <- partitionEithers <$> mapM cmdAction ts
-  write sndQ $ fst as
-  write rcvQ $ snd as
+  case cmdOrError of
+    Left e -> write sndQ (corrId, queueId, ERR e)
+    Right cmd -> do
+      verified <- verifyTransmission sig signed queueId cmd
+      if verified
+        then write rcvQ (corrId, queueId, cmd)
+        else write sndQ (corrId, queueId, ERR AUTH)
   where
-    cmdAction :: SignedTransmission Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
-    cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
-      case cmdOrError of
-        Left e -> pure $ Left (corrId, queueId, ERR e)
-        Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
-          where
-            verified = \case
-              VRVerified qr -> Right (qr, (corrId, queueId, cmd))
-              VRFailed -> Left (corrId, queueId, ERR AUTH)
-    write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
+    write q t = atomically $ writeTBQueue q t
 
-send :: Transport c => THandle c -> Client -> IO ()
+send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
 send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
-  ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-  void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
+  t <- atomically $ readTBQueue sndQ
+  -- TODO the line below can return Left, but we ignore it and do not disconnect the client
+  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
-  where
-    tOrder :: Transmission BrokerMsg -> Int
-    tOrder (_, _, cmd) = case cmd of
-      MSG {} -> 0
-      _ -> 1
 
-disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
+disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
 disconnectTransport THandle {connection} c activeAt expCfg = do
   let interval = checkInterval expCfg * 1000000
   forever . liftIO $ do
@@ -297,27 +261,23 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
     ts <- readTVarIO $ activeAt c
     when (systemSeconds ts < old) $ closeConnection connection
 
-data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
-
-verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
+verifyTransmission ::
+  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
 verifyTransmission sig_ signed queueId cmd = do
   case cmd of
-    Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
+    Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
     Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
-    Cmd SSender PING -> pure $ VRVerified Nothing
-    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
+    Cmd SSender PING -> pure True
+    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
     verifyCmd party f = do
       st <- asks queueStore
-      q_ <- atomically (getQueue st party queueId)
-      pure $ case q_ of
-        Right q -> Just q `verified` f q
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+      q <- atomically $ getQueue st party queueId
+      pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
     verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
     verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
-    verified q cond = if cond then VRVerified q else VRFailed
 
 verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
 verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
@@ -345,43 +305,38 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
+client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
-      >>= mapM processCommand
+      >>= processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
-    processCommand (qr_, (corrId, queueId, cmd)) = do
+    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
+    processCommand (corrId, queueId, cmd) = do
       st <- asks queueStore
       case cmd of
         Cmd SSender command ->
           case command of
-            SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
+            SEND flags msgBody -> sendMessage st flags msgBody
             PING -> pure (corrId, "", PONG)
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
           case command of
-            NEW rKey dhKey auth ->
+            NEW rKey dhKey ->
               ifM
-                allowNew
+                (asks $ allowNewQueues . config)
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
-              where
-                allowNew = do
-                  ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
-                  pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
-            SUB -> withQueue (`subscribeQueue` queueId)
-            GET -> withQueue getMessage
-            ACK msgId -> withQueue (`acknowledgeMsg` msgId)
+            SUB -> subscribeQueue queueId
+            GET -> getMessage
+            ACK msgId -> acknowledgeMsg msgId
             KEY sKey -> secureQueue_ st sKey
-            NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
-            NDEL -> deleteQueueNotifier_ st
+            NKEY nKey -> addQueueNotifier_ st nKey
             OFF -> suspendQueue_ st
             DEL -> delQueueAndMsgs st
       where
         createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg)
-        createQueue st recipientKey dhKey = time "NEW" $ do
+        createQueue st recipientKey dhKey = do
           (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvDhSecret = C.dh' dhKey privDhKey
               qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
@@ -403,16 +358,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             addQueueRetry n qik qRec = do
               ids@(rId, _) <- getIds
               -- create QueueRec record with these ids and keys
-              let qr = qRec ids
-              atomically (addQueue st qr) >>= \case
+              atomically (addQueue st $ qRec ids) >>= \case
                 Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
                 Left e -> pure $ ERR e
                 Right _ -> do
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
-                  atomically $ modifyTVar' (qCreated stats) (+ 1)
-                  atomically $ modifyTVar' (qCount stats) (+ 1)
-                  subscribeQueue qr rId $> IDS (qik ids)
+                  atomically $ modifyTVar (qCreated stats) (+ 1)
+                  subscribeQueue rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -426,45 +379,36 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               liftM2 (,) (randomId n) (randomId n)
 
         secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
-        secureQueue_ st sKey = time "KEY" $ do
+        secureQueue_ st sKey = do
           withLog $ \s -> logSecureQueue s queueId sKey
           stats <- asks serverStats
-          atomically $ modifyTVar' (qSecured stats) (+ 1)
+          atomically $ modifyTVar (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
-        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
-        addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
-          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
-          let rcvNtfDhSecret = C.dh' dhKey privDhKey
-          (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
+        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
+        addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
           where
-            addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> m BrokerMsg
-            addNotifierRetry 0 _ _ = pure $ ERR INTERNAL
-            addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
-              notifierId <- randomId =<< asks (queueIdBytes . config)
-              let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
-              atomically (addQueueNotifier st queueId ntfCreds) >>= \case
-                Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
+            addNotifierRetry :: Int -> m BrokerMsg
+            addNotifierRetry 0 = pure $ ERR INTERNAL
+            addNotifierRetry n = do
+              nId <- randomId =<< asks (queueIdBytes . config)
+              atomically (addQueueNotifier st queueId nId nKey) >>= \case
+                Left DUPLICATE_ -> addNotifierRetry $ n - 1
                 Left e -> pure $ ERR e
                 Right _ -> do
-                  withLog $ \s -> logAddNotifier s queueId ntfCreds
-                  pure $ NID notifierId rcvPublicDhKey
-
-        deleteQueueNotifier_ :: QueueStore -> m (Transmission BrokerMsg)
-        deleteQueueNotifier_ st = do
-          withLog (`logDeleteNotifier` queueId)
-          okResp <$> atomically (deleteQueueNotifier st queueId)
+                  withLog $ \s -> logAddNotifier s queueId nId nKey
+                  pure $ NID nId
 
         suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
-          withLog (`logSuspendQueue` queueId)
+          withLog (`logDeleteQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue qr rId = do
+        subscribeQueue :: RecipientId -> m (Transmission BrokerMsg)
+        subscribeQueue rId =
           atomically (TM.lookup rId subscriptions) >>= \case
             Nothing ->
-              newSub >>= deliver
+              atomically newSub >>= deliver
             Just sub ->
               readTVarIO sub >>= \case
                 Sub {subThread = ProhibitSub} ->
@@ -473,20 +417,20 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 s ->
                   atomically (tryTakeTMVar $ delivered s) >> deliver sub
           where
-            newSub :: m (TVar Sub)
-            newSub = time "SUB newSub" . atomically $ do
+            newSub :: STM (TVar Sub)
+            newSub = do
               writeTBQueue subscribedQ (rId, clnt)
               sub <- newTVar =<< newSubscription NoSub
               TM.insert rId sub subscriptions
               pure sub
             deliver :: TVar Sub -> m (Transmission BrokerMsg)
             deliver sub = do
-              q <- getStoreMsgQueue "SUB" rId
+              q <- getStoreMsgQueue rId
               msg_ <- atomically $ tryPeekMsg q
-              deliverMessage "SUB" qr rId sub q msg_
+              deliverMessage rId sub q msg_
 
-        getMessage :: QueueRec -> m (Transmission BrokerMsg)
-        getMessage qr = time "GET" $ do
+        getMessage :: m (Transmission BrokerMsg)
+        getMessage =
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= getMessage_
@@ -506,182 +450,149 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               pure s
             getMessage_ :: Sub -> m (Transmission BrokerMsg)
             getMessage_ s = do
-              q <- getStoreMsgQueue "GET" queueId
+              q <- getStoreMsgQueue queueId
               atomically $
                 tryPeekMsg q >>= \case
-                  Just msg ->
-                    let encMsg = encryptMsg qr msg
-                     in setDelivered s msg $> (corrId, queueId, MSG encMsg)
+                  Just msg -> setDelivered s msg $> (corrId, queueId, msgCmd msg)
                   _ -> pure (corrId, queueId, OK)
 
-        withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
-        withQueue action = maybe (pure $ err AUTH) action qr_
-
         subscribeNotifications :: m (Transmission BrokerMsg)
-        subscribeNotifications = time "NSUB" . atomically $ do
+        subscribeNotifications = atomically $ do
           unlessM (TM.member queueId ntfSubscriptions) $ do
             writeTBQueue ntfSubscribedQ (queueId, clnt)
             TM.insert queueId () ntfSubscriptions
           pure ok
 
-        acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg qr msgId = time "ACK" $ do
+        acknowledgeMsg :: MsgId -> m (Transmission BrokerMsg)
+        acknowledgeMsg msgId = do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing -> pure $ err NO_MSG
             Just sub ->
               atomically (getDelivered sub) >>= \case
                 Just s -> do
-                  q <- getStoreMsgQueue "ACK" queueId
+                  q <- getStoreMsgQueue queueId
                   case s of
                     Sub {subThread = ProhibitSub} -> do
-                      deletedMsg_ <- atomically $ tryDelMsg q msgId
-                      mapM_ updateStats deletedMsg_
+                      msgDeleted <- atomically $ tryDelMsg q msgId
+                      when msgDeleted updateStats
                       pure ok
                     _ -> do
-                      (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId
-                      mapM_ updateStats deletedMsg_
-                      deliverMessage "ACK" qr queueId sub q msg_
+                      (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
+                      when msgDeleted updateStats
+                      deliverMessage queueId sub q msg_
                 _ -> pure $ err NO_MSG
           where
             getDelivered :: TVar Sub -> STM (Maybe Sub)
             getDelivered sub = do
               s@Sub {delivered} <- readTVar sub
               tryTakeTMVar delivered $>>= \msgId' ->
-                if msgId == msgId' || B.null msgId
+                if B.null msgId || msgId == msgId'
                   then pure $ Just s
                   else putTMVar delivered msgId' $> Nothing
-            updateStats :: Message -> m ()
-            updateStats = \case
-              MessageQuota {} -> pure ()
-              Message {msgFlags} -> do
-                stats <- asks serverStats
-                atomically $ modifyTVar' (msgRecv stats) (+ 1)
-                atomically $ modifyTVar' (msgCount stats) (+ 1)
-                atomically $ updatePeriodStats (activeQueues stats) queueId
-                when (notification msgFlags) $ do
-                  atomically $ modifyTVar' (msgRecvNtf stats) (+ 1)
-                  atomically $ updatePeriodStats (activeQueuesNtf stats) queueId
+            updateStats :: m ()
+            updateStats = do
+              stats <- asks serverStats
+              atomically $ modifyTVar (msgRecv stats) (+ 1)
+              atomically $ updateActiveQueues stats queueId
 
-        sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage qr msgFlags msgBody
-          | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
-          | otherwise = case status qr of
-            QueueOff -> return $ err AUTH
-            QueueActive ->
-              case C.maxLenBS msgBody of
-                Left _ -> pure $ err LARGE_MSG
-                Right body -> do
-                  msg_ <- time "SEND" $ do
-                    q <- getStoreMsgQueue "SEND" $ recipientId qr
-                    expireMessages q
-                    atomically . writeMsg q =<< mkMessage body
-                  case msg_ of
-                    Nothing -> pure $ err QUOTA
-                    Just msg -> time "SEND ok" $ do
-                      stats <- asks serverStats
-                      when (notification msgFlags) $ do
-                        atomically . trySendNotification msg =<< asks idsDrg
-                        atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
-                        atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
-                      atomically $ modifyTVar' (msgSent stats) (+ 1)
-                      atomically $ modifyTVar' (msgCount stats) (subtract 1)
-                      atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
-                      pure ok
+        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
+        updateActiveQueues stats qId = do
+          updatePeriod dayMsgQueues
+          updatePeriod weekMsgQueues
+          updatePeriod monthMsgQueues
           where
-            mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
-            mkMessage body = do
-              msgId <- randomId =<< asks (msgIdBytes . config)
-              msgTs <- liftIO getSystemTime
-              pure $ Message msgId msgTs msgFlags body
+            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
 
-            expireMessages :: MsgQueue -> m ()
-            expireMessages q = do
-              msgExp <- asks $ messageExpiration . config
-              old <- liftIO $ mapM expireBeforeEpoch msgExp
-              atomically $ mapM_ (deleteExpiredMsgs q) old
+        sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage st flags msgBody
+          | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
+          | otherwise = do
+            qr <- atomically $ getQueue st SSender queueId
+            either (return . err) storeMessage qr
+          where
+            storeMessage :: QueueRec -> m (Transmission BrokerMsg)
+            storeMessage qr = case status qr of
+              QueueOff -> return $ err AUTH
+              QueueActive ->
+                mkMessage >>= \case
+                  Left _ -> pure $ err LARGE_MSG
+                  Right msg -> do
+                    ms <- asks msgStore
+                    ServerConfig {messageExpiration, msgQueueQuota} <- asks config
+                    old <- liftIO $ mapM expireBeforeEpoch messageExpiration
+                    resp@(_, _, sent) <- atomically $ do
+                      q <- getMsgQueue ms (recipientId qr) msgQueueQuota
+                      mapM_ (deleteExpiredMsgs q) old
+                      ifM (isFull q) (pure $ err QUOTA) $ do
+                        when (notification flags) trySendNotification
+                        writeMsg q msg
+                        pure ok
+                    when (sent == OK) $ do
+                      stats <- asks serverStats
+                      atomically $ modifyTVar (msgSent stats) (+ 1)
+                      atomically $ updateActiveQueues stats $ recipientId qr
+                    pure resp
+              where
+                mkMessage :: m (Either C.CryptoError Message)
+                mkMessage = do
+                  msgId <- randomId =<< asks (msgIdBytes . config)
+                  ts <- liftIO getSystemTime
+                  let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
+                  pure $ Message msgId ts flags <$> c
 
-            trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
-            trySendNotification msg ntfNonceDrg =
-              forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
-                mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
+                trySendNotification :: STM ()
+                trySendNotification =
+                  forM_ (notifier qr) $ \(nId, _) ->
+                    mapM_ (writeNtf nId) =<< TM.lookup nId notifiers
 
-            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
-            writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-              unlessM (isFullTBQueue q) $ case msg of
-                Message {msgId, msgTs} -> do
-                  (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
-                  writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
-                _ -> pure ()
+                writeNtf :: NotifierId -> Client -> STM ()
+                writeNtf nId Client {sndQ = q} =
+                  unlessM (isFullTBQueue sndQ) $
+                    writeTBQueue q (CorrId "", nId, NMSG)
 
-            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-            mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
-              cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
-              let msgMeta = NMsgMeta {msgId, msgTs}
-                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
-              pure . (cbNonce,) $ fromRight "" encNMsgMeta
-
-        deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do
+        deliverMessage :: RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
+        deliverMessage rId sub q msg_ =
           readTVarIO sub >>= \case
             s@Sub {subThread = NoSub} ->
               case msg_ of
-                Just msg ->
-                  let encMsg = encryptMsg qr msg
-                   in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
+                Just msg -> atomically (setDelivered s msg) $> (corrId, rId, msgCmd msg)
                 _ -> forkSub $> ok
             _ -> pure ok
           where
             forkSub :: m ()
             forkSub = do
-              atomically . modifyTVar' sub $ \s -> s {subThread = SubPending}
+              atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
               t <- mkWeakThreadId =<< forkIO subscriber
-              atomically . modifyTVar' sub $ \case
+              atomically . modifyTVar sub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
-              where
-                subscriber = do
-                  msg <- atomically $ peekMsg q
-                  time "subscriber" . atomically $ do
-                    let encMsg = encryptMsg qr msg
-                    writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
-                    s <- readTVar sub
-                    void $ setDelivered s msg
-                    writeTVar sub $! s {subThread = NoSub}
 
-        time :: T.Text -> m a -> m a
-        time name = timed name queueId
-
-        encryptMsg :: QueueRec -> Message -> RcvMessage
-        encryptMsg qr msg = case msg of
-          Message {msgFlags, msgBody}
-            | thVersion == 1 || thVersion == 2 -> encrypt msgFlags msgBody
-            | otherwise -> encrypt msgFlags $ encodeRcvMsgBody RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
-          MessageQuota {} ->
-            encrypt noMsgFlags $ encodeRcvMsgBody (RcvMsgQuota msgTs')
-          where
-            encrypt :: KnownNat i => MsgFlags -> C.MaxLenBS i -> RcvMessage
-            encrypt msgFlags body =
-              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body
-               in RcvMessage msgId' msgTs' msgFlags encBody
-            msgId' = msgId (msg :: Message)
-            msgTs' = msgTs (msg :: Message)
+            subscriber :: m ()
+            subscriber = atomically $ do
+              msg <- peekMsg q
+              writeTBQueue sndQ (CorrId "", rId, msgCmd msg)
+              s <- readTVar sub
+              void $ setDelivered s msg
+              writeTVar sub s {subThread = NoSub}
 
         setDelivered :: Sub -> Message -> STM Bool
-        setDelivered s msg = tryPutTMVar (delivered s) $ msgId (msg :: Message)
+        setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
 
-        getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue
-        getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
+        getStoreMsgQueue :: RecipientId -> m MsgQueue
+        getStoreMsgQueue rId = do
           ms <- asks msgStore
           quota <- asks $ msgQueueQuota . config
           atomically $ getMsgQueue ms rId quota
 
+        msgCmd :: Message -> BrokerMsg
+        msgCmd Message {msgId, ts, msgFlags, msgBody} = MSG msgId ts msgFlags msgBody
+
         delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
         delQueueAndMsgs st = do
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
           stats <- asks serverStats
-          atomically $ modifyTVar' (qDeleted stats) (+ 1)
-          atomically $ modifyTVar' (qCount stats) (subtract 1)
+          atomically $ modifyTVar (qDeleted stats) (+ 1)
           atomically $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -701,100 +612,38 @@ withLog action = do
   env <- ask
   liftIO . mapM_ action $ storeLog (env :: Env)
 
-timed :: MonadUnliftIO m => T.Text -> RecipientId -> m a -> m a
-timed name qId a = do
-  t <- liftIO getSystemTime
-  r <- a
-  t' <- liftIO getSystemTime
-  let int = diff t t'
-  when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int]
-  pure r
-  where
-    diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
-    sec = 1000_000000
-
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
   atomically (C.pseudoRandomBytes n gVar)
 
-saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
+saveServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
 saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
   where
     saveMessages f = do
-      logInfo $ "saving messages to file " <> T.pack f
+      liftIO $ putStrLn $ "saving messages to file " <> f
       ms <- asks msgStore
       liftIO . withFile f WriteMode $ \h ->
         readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
-      logInfo "messages saved"
       where
         saveQueueMsgs ms h rId =
           atomically (flushMsgQueue ms rId)
-            >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
+            >>= mapM_ (B.hPutStrLn h . strEncode . MsgLogRecord rId)
 
 restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
 restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
   where
     restoreMessages f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring messages from file " <> T.pack f
-      st <- asks queueStore
+      liftIO $ putStrLn $ "restoring messages from file " <> f
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
-      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
-        Left e -> do
-          logError . T.pack $ "error restoring messages: " <> e
-          liftIO exitFailure
-        _ -> do
-          renameFile f $ f <> ".bak"
-          logInfo "messages restored"
+      liftIO $ mapM_ (restoreMsg ms quota) . B.lines =<< B.readFile f
+      renameFile f $ f <> ".bak"
       where
-        restoreMsg st ms quota s = do
-          r <- liftEither . first (msgErr "parsing") $ strDecode s
-          case r of
-            MLRv3 rId msg -> addToMsgQueue rId msg
-            MLRv1 rId encMsg -> do
-              qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
-              msg' <- updateMsgV1toV3 qr encMsg
-              addToMsgQueue rId msg'
-          where
-            addToMsgQueue rId msg = do
-              full <- atomically $ do
-                q <- getMsgQueue ms rId quota
-                isNothing <$> writeMsg q msg
-              case msg of
-                Message {} ->
-                  when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
-                MessageQuota {} -> pure ()
-            updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
-              let nonce = C.cbNonce msgId
-              msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
-              pure Message {msgId, msgTs, msgFlags, msgBody}
-            msgErr :: Show e => String -> e -> String
-            msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
-
-saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-saveServerStats =
-  asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
-  where
-    saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
-      B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
-
-restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
-  where
-    restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
-      liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d -> do
-          s <- asks serverStats
-          _qCount <- fmap (length . M.keys) . readTVarIO . queues =<< asks queueStore
-          _msgCount <- foldM (\n q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
-          atomically $ setServerStats s d {_qCount, _msgCount}
-          renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
-        Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
-          liftIO exitFailure
+        restoreMsg ms quota s = case strDecode s of
+          Left e -> B.putStrLn $ "message parsing error (" <> B.pack e <> "): " <> B.take 100 s
+          Right (MsgLogRecord rId msg) -> do
+            full <- atomically $ do
+              q <- getMsgQueue ms rId quota
+              ifM (isFull q) (pure True) (writeMsg q msg $> False)
+            when full . B.putStrLn $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId msg)

src/Simplex/Messaging/Server/CLI.hs

@@ -13,133 +13,213 @@ import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
-import Data.Ini (Ini, lookupValue)
-import Data.Text (Text)
+import Data.Ini (Ini, lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (loadFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (whenM)
-import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
-import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
+import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
 import System.Process (readCreateProcess, shell)
+import Text.Read (readMaybe)
 
-exitError :: String -> IO ()
-exitError msg = putStrLn msg >> exitFailure
-
-confirmOrExit :: String -> IO ()
-confirmOrExit s =
-  withPrompt (s <> "\nContinue (Y/n): ") $ do
-    ok <- getLine
-    when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
-
-data SignAlgorithm = ED448 | ED25519
-  deriving (Read, Show)
-
-data X509Config = X509Config
-  { commonName :: HostName,
-    signAlgorithm :: SignAlgorithm,
+data ServerCLIConfig cfg = ServerCLIConfig
+  { cfgDir :: FilePath,
+    logDir :: FilePath,
+    iniFile :: FilePath,
+    storeLogFile :: FilePath,
     caKeyFile :: FilePath,
     caCrtFile :: FilePath,
     serverKeyFile :: FilePath,
     serverCrtFile :: FilePath,
     fingerprintFile :: FilePath,
-    opensslCaConfFile :: FilePath,
-    opensslServerConfFile :: FilePath,
-    serverCsrFile :: FilePath
+    defaultServerPort :: ServiceName,
+    executableName :: String,
+    serverVersion :: String,
+    mkIniFile :: Bool -> ServiceName -> String,
+    mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
   }
 
-defaultX509Config :: X509Config
-defaultX509Config =
-  X509Config
-    { commonName = "127.0.0.1",
-      signAlgorithm = ED448,
-      caKeyFile = "ca.key",
-      caCrtFile = "ca.crt",
-      serverKeyFile = "server.key",
-      serverCrtFile = "server.crt",
-      fingerprintFile = "fingerprint",
-      opensslCaConfFile = "openssl_ca.conf",
-      opensslServerConfFile = "openssl_server.conf",
-      serverCsrFile = "server.csr"
-    }
+protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
+protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
+  getCliCommand cliCfg >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
+        _ -> initializeServer cliCfg opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    Delete -> do
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      cleanup cliCfg
+      putStrLn "Deleted configuration and log files"
 
-getCliCommand' :: Parser cmd -> String -> IO cmd
-getCliCommand' cmdP version =
+exitError :: String -> IO ()
+exitError msg = putStrLn msg >> exitFailure
+
+confirmOrExit :: String -> IO ()
+confirmOrExit s = do
+  putStrLn s
+  putStr "Continue (Y/n): "
+  hFlush stdout
+  ok <- getLine
+  when (ok /= "Y") exitFailure
+
+data CliCommand
+  = Init InitOptions
+  | Start
+  | Delete
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName
+  }
+  deriving (Show)
+
+data SignAlgorithm = ED448 | ED25519
+  deriving (Read, Show)
+
+getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
+getCliCommand cliCfg =
   customExecParser
     (prefs showHelpOnEmpty)
     ( info
-        (helper <*> versionOption <*> cmdP)
+        (helper <*> versionOption <*> cliCommandP cliCfg)
         (header version <> fullDesc)
     )
   where
     versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
+    version = serverVersion cliCfg
 
-createServerX509 :: FilePath -> X509Config -> IO ByteString
-createServerX509 cfgPath x509cfg = do
-  createOpensslCaConf
-  createOpensslServerConf
-  let alg = show $ signAlgorithm (x509cfg :: X509Config)
-  -- CA certificate (identity/offline)
-  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
-  run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
-  -- server certificate (online)
-  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile
-  run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile
-  run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile
-  saveFingerprint
+cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
+cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
+  hsubparser
+    ( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
+        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+    )
   where
-    run cmd = void $ readCreateProcess (shell cmd) ""
-    c = combine cfgPath . ($ x509cfg)
-    createOpensslCaConf =
-      writeFile
-        (c opensslCaConfFile)
-        "[req]\n\
-        \distinguished_name = req_distinguished_name\n\
-        \prompt = no\n\n\
-        \[req_distinguished_name]\n\
-        \CN = SMP server CA\n\
-        \O = SimpleX\n\n\
-        \[v3]\n\
-        \subjectKeyIdentifier = hash\n\
-        \authorityKeyIdentifier = keyid:always\n\
-        \basicConstraints = critical,CA:true\n"
-    createOpensslServerConf =
-      writeFile
-        (c opensslServerConfFile)
-        ( "[req]\n\
-          \distinguished_name = req_distinguished_name\n\
-          \prompt = no\n\n\
-          \[req_distinguished_name]\n"
-            <> ("CN = " <> commonName x509cfg <> "\n\n")
-            <> "[v3]\n\
-               \basicConstraints = CA:FALSE\n\
-               \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
-               \extendedKeyUsage = serverAuth\n"
-        )
+    initP :: Parser CliCommand
+    initP =
+      Init
+        <$> ( InitOptions
+                <$> switch
+                  ( long "store-log"
+                      <> short 'l'
+                      <> help "Enable store log for persistence"
+                  )
+                <*> option
+                  (maybeReader readMaybe)
+                  ( long "sign-algorithm"
+                      <> short 'a'
+                      <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
+                      <> value ED448
+                      <> showDefault
+                      <> metavar "ALG"
+                  )
+                <*> strOption
+                  ( long "ip"
+                      <> help
+                        "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
+                      <> value "127.0.0.1"
+                      <> showDefault
+                      <> metavar "IP"
+                  )
+                <*> (optional . strOption)
+                  ( long "fqdn"
+                      <> short 'n'
+                      <> help "Server FQDN used as Common Name for TLS online certificate"
+                      <> showDefault
+                      <> metavar "FQDN"
+                  )
+            )
+
+initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
+initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+  cleanup cliCfg
+  createDirectoryIfMissing True cfgDir
+  createDirectoryIfMissing True logDir
+  createX509
+  fp <- saveFingerprint
+  writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
+  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+  printServiceInfo cliCfg fp
+  warnCAPrivateKeyFile
+  where
+    ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
+    createX509 = do
+      createOpensslCaConf
+      createOpensslServerConf
+      -- CA certificate (identity/offline)
+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
+      run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
+      -- server certificate (online)
+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
+      run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
+      run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
+      where
+        run cmd = void $ readCreateProcess (shell cmd) ""
+        opensslCaConfFile = combine cfgDir "openssl_ca.conf"
+        opensslServerConfFile = combine cfgDir "openssl_server.conf"
+        serverCsrFile = combine cfgDir "server.csr"
+        createOpensslCaConf =
+          writeFile
+            opensslCaConfFile
+            "[req]\n\
+            \distinguished_name = req_distinguished_name\n\
+            \prompt = no\n\n\
+            \[req_distinguished_name]\n\
+            \CN = SMP server CA\n\
+            \O = SimpleX\n\n\
+            \[v3]\n\
+            \subjectKeyIdentifier = hash\n\
+            \authorityKeyIdentifier = keyid:always\n\
+            \basicConstraints = critical,CA:true\n"
+        -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
+        -- IP and FQDN can't both be used as server address interchangeably even if IP is added
+        -- as Subject Alternative Name, unless the following validation hook is disabled:
+        -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
+        createOpensslServerConf =
+          writeFile
+            opensslServerConfFile
+            ( "[req]\n\
+              \distinguished_name = req_distinguished_name\n\
+              \prompt = no\n\n\
+              \[req_distinguished_name]\n"
+                <> ("CN = " <> cn <> "\n\n")
+                <> "[v3]\n\
+                   \basicConstraints = CA:FALSE\n\
+                   \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
+                   \extendedKeyUsage = serverAuth\n"
+            )
+          where
+            cn = fromMaybe ip fqdn
 
     saveFingerprint = do
-      Fingerprint fp <- loadFingerprint $ c caCrtFile
-      withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
+      Fingerprint fp <- loadFingerprint caCrtFile
+      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
       pure fp
 
-warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
-warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} =
-  putStrLn $
-    "----------\n\
-    \You should store CA private key securely and delete it from the server.\n\
-    \If server TLS credential is compromised this key can be used to sign a new one, \
-    \keeping the same server identity and established connections.\n\
-    \CA private key location:\n"
-      <> combine cfgPath caKeyFile
-      <> "\n----------"
+    warnCAPrivateKeyFile =
+      putStrLn $
+        "----------\n\
+        \You should store CA private key securely and delete it from the server.\n\
+        \If server TLS credential is compromised this key can be used to sign a new one, \
+        \keeping the same server identity and established connections.\n\
+        \CA private key location:\n"
+          <> caKeyFile
+          <> "\n----------"
 
 data IniOptions = IniOptions
   { enableStoreLog :: Bool,
@@ -155,76 +235,50 @@ mkIniOptions ini =
       enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
     }
 
-strictIni :: Text -> Text -> Ini -> Text
+strictIni :: String -> String -> Ini -> T.Text
 strictIni section key ini =
-  fromRight (error . T.unpack $ "no key " <> key <> " in section " <> section) $
-    lookupValue section key ini
+  fromRight (error ("no key " <> key <> " in section " <> section)) $
+    lookupValue (T.pack section) (T.pack key) ini
 
-readStrictIni :: Read a => Text -> Text -> Ini -> a
+readStrictIni :: Read a => String -> String -> Ini -> a
 readStrictIni section key = read . T.unpack . strictIni section key
 
-iniOnOff :: Text -> Text -> Ini -> Maybe Bool
-iniOnOff section name ini = case lookupValue section name ini of
-  Right "on" -> Just True
-  Right "off" -> Just False
-  Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s
-  _ -> Nothing
-
-withPrompt :: String -> IO a -> IO a
-withPrompt s a = putStr s >> hFlush stdout >> a
-
-onOffPrompt :: String -> Bool -> IO Bool
-onOffPrompt prompt def =
-  withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $
-    getLine >>= \case
-      "" -> pure def
-      "y" -> pure True
-      "Y" -> pure True
-      "n" -> pure False
-      "N" -> pure False
-      _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def
-
-onOff :: Bool -> String
-onOff True = "on"
-onOff _ = "off"
-
-settingIsOn :: Text -> Text -> Ini -> Maybe ()
-settingIsOn section name ini
-  | iniOnOff section name ini == Just True = Just ()
-  | otherwise = Nothing
-
-checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
-checkSavedFingerprint cfgPath x509cfg = do
-  savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
-  Fingerprint fp <- loadFingerprint (c caCrtFile)
-  when (B.pack savedFingerprint /= strEncode fp) $
-    exitError "Stored fingerprint is invalid."
-  pure fp
+runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
+runServer cliCfg server ini = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  fp <- checkSavedFingerprint
+  printServiceInfo cliCfg fp
+  let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
+      transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
+      logFile = if enableStoreLog then Just storeLogFile else Nothing
+      cfg = mkServerConfig logFile transports ini
+  printServerConfig logFile transports
+  server cfg
   where
-    c = combine cfgPath . ($ x509cfg)
+    ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
+    checkSavedFingerprint = do
+      savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
+      Fingerprint fp <- loadFingerprint caCrtFile
+      when (B.pack savedFingerprint /= strEncode fp) $
+        exitError "Stored fingerprint is invalid."
+      pure fp
 
-iniTransports :: Ini -> [(String, ATransport)]
-iniTransports ini =
-  let port = T.unpack $ strictIni "TRANSPORT" "port" ini
-      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
-   in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
+    printServerConfig logFile transports = do
+      putStrLn $ case logFile of
+        Just f -> "Store log: " <> f
+        _ -> "Store log disabled."
+      forM_ transports $ \(p, ATransport t) ->
+        putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
 
-printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
-printServerConfig transports logFile = do
-  putStrLn $ case logFile of
-    Just f -> "Store log: " <> f
-    _ -> "Store log disabled."
-  forM_ transports $ \(p, ATransport t) ->
-    putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
+cleanup :: ServerCLIConfig cfg -> IO ()
+cleanup ServerCLIConfig {cfgDir, logDir} = do
+  deleteDirIfExists cfgDir
+  deleteDirIfExists logDir
+  where
+    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
 
-deleteDirIfExists :: FilePath -> IO ()
-deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
-
-printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO ()
-printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash} _) = do
+printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
+printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
   putStrLn serverVersion
-  B.putStrLn $ "Fingerprint: " <> strEncode keyHash
-  B.putStrLn $ "Server address: " <> strEncode srv
-
-clearDirIfExists :: FilePath -> IO ()
-clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
+  B.putStrLn $ "Fingerprint: " <> strEncode fpStr

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -9,10 +10,11 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
-import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Time.Clock (getCurrentTime)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
@@ -22,9 +24,8 @@ import Simplex.Messaging.Crypto (KeyHash (..))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.STM
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
+import Simplex.Messaging.Server.QueueStore (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -39,15 +40,13 @@ data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
     tbqSize :: Natural,
     serverTbqSize :: Natural,
-    msgQueueQuota :: Int,
+    msgQueueQuota :: Natural,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
     storeMsgsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
-    -- | simple password that the clients need to pass in handshake to be able to create new queues
-    newQueueBasicAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -58,17 +57,12 @@ data ServerConfig = ServerConfig
     -- | time of the day when the stats are logged first, to log at consistent times,
     -- irrespective of when the server is started (seconds from 00:00 UTC)
     logStatsStartTime :: Int,
-    -- | file to log stats
-    serverStatsLogFile :: FilePath,
-    -- | file to save and restore stats
-    serverStatsBackupFile :: Maybe FilePath,
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange,
-    logTLSErrors :: Bool
+    smpServerVRange :: VersionRange
   }
 
 defaultMessageExpiration :: ExpirationConfig
@@ -107,14 +101,25 @@ data Server = Server
 data Client = Client
   { subscriptions :: TMap RecipientId (TVar Sub),
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
-    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
-    thVersion :: Version,
+    rcvQ :: TBQueue (Transmission Cmd),
+    sndQ :: TBQueue (Transmission BrokerMsg),
     sessionId :: ByteString,
     connected :: TVar Bool,
     activeAt :: TVar SystemTime
   }
 
+data ServerStats = ServerStats
+  { qCreated :: TVar Int,
+    qSecured :: TVar Int,
+    qDeleted :: TVar Int,
+    msgSent :: TVar Int,
+    msgRecv :: TVar Int,
+    dayMsgQueues :: TVar (Set RecipientId),
+    weekMsgQueues :: TVar (Set RecipientId),
+    monthMsgQueues :: TVar (Set RecipientId),
+    fromTime :: TVar UTCTime
+  }
+
 data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
 
 data Sub = Sub
@@ -130,15 +135,28 @@ newServer qSize = do
   notifiers <- TM.empty
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
-newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
-newClient qSize thVersion sessionId ts = do
+newClient :: Natural -> ByteString -> SystemTime -> STM Client
+newClient qSize sessionId ts = do
   subscriptions <- TM.empty
   ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
   activeAt <- newTVar ts
-  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected, activeAt}
+
+newServerStats :: UTCTime -> STM ServerStats
+newServerStats ts = do
+  qCreated <- newTVar 0
+  qSecured <- newTVar 0
+  qDeleted <- newTVar 0
+  msgSent <- newTVar 0
+  msgRecv <- newTVar 0
+  dayMsgQueues <- newTVar S.empty
+  weekMsgQueues <- newTVar S.empty
+  monthMsgQueues <- newTVar S.empty
+  fromTime <- newTVar ts
+  pure ServerStats {qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues, fromTime}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription subThread = do
@@ -164,12 +182,12 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
       (qs, s') <- liftIO $ readWriteStoreLog s
       atomically $ do
         writeTVar queues =<< mapM newTVar qs
-        writeTVar senders $! M.foldr' addSender M.empty qs
-        writeTVar notifiers $! M.foldr' addNotifier M.empty qs
+        writeTVar senders $ M.foldr' addSender M.empty qs
+        writeTVar notifiers $ M.foldr' addNotifier M.empty qs
       pure s'
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)
     addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
     addNotifier q = case notifier q of
       Nothing -> id
-      Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)
+      Just (nId, _) -> M.insert nId (recipientId q)

src/Simplex/Messaging/Server/Main.hs

@@ -1,285 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Simplex.Messaging.Server.Main where
-
-import Control.Monad (void)
-import Crypto.Random (getRandomBytes)
-import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Network.Socket (HostName)
-import Options.Applicative
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
-import Simplex.Messaging.Server (runSMPServer)
-import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
-import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Util (safeDecodeUtf8)
-import System.Directory (createDirectoryIfMissing, doesFileExist)
-import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
-import Text.Read (readMaybe)
-
-smpServerCLI :: FilePath -> FilePath -> IO ()
-smpServerCLI cfgPath logPath =
-  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
-    Init opts ->
-      doesFileExist iniFile >>= \case
-        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
-        _ -> initializeServer opts
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-      deleteDirIfExists cfgPath
-      deleteDirIfExists logPath
-      putStrLn "Deleted configuration and log files"
-  where
-    iniFile = combine cfgPath "smp-server.ini"
-    serverVersion = "SMP server v" <> simplexMQVersion
-    defaultServerPort = "5223"
-    executableName = "smp-server"
-    storeLogFilePath = combine logPath "smp-server-store.log"
-    initializeServer opts
-      | scripted opts = initialize opts
-      | otherwise = do
-        putStrLn "Use `smp-server init -h` for available options."
-        void $ withPrompt "SMP server will be initialized (press Enter)" getLine
-        enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
-        logStats <- onOffPrompt "Enable logging daily statistics" False
-        putStrLn "Require a password to create new messaging queues?"
-        password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
-        let host = fromMaybe (ip opts) (fqdn opts)
-        host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
-        initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
-      where
-        serverPassword =
-          getLine >>= \case
-            "" -> pure $ Just SPRandom
-            "r" -> pure $ Just SPRandom
-            "n" -> pure Nothing
-            s ->
-              case strDecode $ encodeUtf8 $ T.pack s of
-                Right auth -> pure . Just $ ServerPassword auth
-                _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
-        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do
-          clearDirIfExists cfgPath
-          clearDirIfExists logPath
-          createDirectoryIfMissing True cfgPath
-          createDirectoryIfMissing True logPath
-          let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
-          fp <- createServerX509 cfgPath x509cfg
-          basicAuth <- mapM createServerPassword password
-          let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-              srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
-          writeFile iniFile $ iniFileContent host basicAuth
-          putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
-          warnCAPrivateKeyFile cfgPath x509cfg
-          printServiceInfo serverVersion srv
-          where
-            createServerPassword = \case
-              ServerPassword s -> pure s
-              SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString)
-            iniFileContent host basicAuth =
-              "[STORE_LOG]\n\
-              \# The server uses STM memory for persistence,\n\
-              \# that will be lost on restart (e.g., as with redis).\n\
-              \# This option enables saving memory to append only log,\n\
-              \# and restoring it when the server is started.\n\
-              \# Log is compacted on start (deleted objects are removed).\n"
-                <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
-                   \# they are preserved in the .bak file until the next restart.\n"
-                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Log daily server statistics to CSV file\n"
-                <> ("log_stats: " <> onOff logStats <> "\n\n")
-                <> "[AUTH]\n\
-                   \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
-                   \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
-                   \new_queues: on\n\n\
-                   \# Use create_password option to enable basic auth to create new messaging queues.\n\
-                   \# The password should be used as part of server address in client configuration:\n\
-                   \# smp://fingerprint:password@host1,host2\n\
-                   \# The password will not be shared with the connecting contacts, you must share it only\n\
-                   \# with the users who you want to allow creating messaging queues on your server.\n"
-                <> ( case basicAuth of
-                       Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
-                       _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
-                   )
-                <> "\n\n\
-                   \[TRANSPORT]\n\
-                   \# host is only used to print server address on start\n"
-                <> ("host: " <> host <> "\n")
-                <> ("port: " <> defaultServerPort <> "\n")
-                <> "log_tls_errors: off\n\
-                   \websockets: off\n\n\
-                   \[INACTIVE_CLIENTS]\n\
-                   \# TTL and interval to check inactive clients\n\
-                   \disconnect: off\n"
-                <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-                <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
-    runServer ini = do
-      hSetBuffering stdout LineBuffering
-      hSetBuffering stderr LineBuffering
-      fp <- checkSavedFingerprint cfgPath defaultX509Config
-      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
-          port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig
-          srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
-      printServiceInfo serverVersion srv
-      printServerConfig transports storeLogFile
-      putStrLn $ case inactiveClientExpiration of
-        Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
-        _ -> "not expiring inactive clients"
-      putStrLn $
-        "creating new queues "
-          <> if allowNewQueues cfg
-            then maybe "allowed" (const "requires password") newQueueBasicAuth
-            else "NOT allowed"
-      runSMPServer cfg
-      where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-        logStats = settingIsOn "STORE_LOG" "log_stats" ini
-        c = combine cfgPath . ($ defaultX509Config)
-        serverConfig =
-          ServerConfig
-            { transports = iniTransports ini,
-              tbqSize = 32,
-              serverTbqSize = 128,
-              msgQueueQuota = 128,
-              queueIdBytes = 24,
-              msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
-              caCertificateFile = c caCrtFile,
-              privateKeyFile = c serverKeyFile,
-              certificateFile = c serverCrtFile,
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile =
-                let messagesPath = combine logPath "smp-server-messages.log"
-                 in case iniOnOff "STORE_LOG" "restore_messages" ini of
-                      Just True -> Just messagesPath
-                      Just False -> Nothing
-                      -- if the setting is not set, it is enabled when store log is enabled
-                      _ -> enableStoreLog $> messagesPath,
-              -- allow creating new queues by default
-              allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
-              newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of
-                Right auth -> either error Just . strDecode $ encodeUtf8 auth
-                _ -> Nothing,
-              messageExpiration = Just defaultMessageExpiration,
-              inactiveClientExpiration =
-                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
-                  $> ExpirationConfig
-                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
-                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                    },
-              logStatsInterval = logStats $> 86400, -- seconds
-              logStatsStartTime = 0, -- seconds from 00:00 UTC
-              serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
-              serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
-              smpServerVRange = supportedSMPServerVRange,
-              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-            }
-
-data CliCommand
-  = Init InitOptions
-  | Start
-  | Delete
-
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    logStats :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName,
-    password :: Maybe ServerPassword,
-    scripted :: Bool
-  }
-  deriving (Show)
-
-data ServerPassword = ServerPassword BasicAuth | SPRandom
-  deriving (Show)
-
-cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
-cliCommandP cfgPath logPath iniFile =
-  hsubparser
-    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
-        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
-    )
-  where
-    initP :: Parser InitOptions
-    initP = do
-      enableStoreLog <-
-        switch
-          ( long "store-log"
-              <> short 'l'
-              <> help "Enable store log for persistence"
-          )
-      logStats <-
-        switch
-          ( long "daily-stats"
-              <> short 's'
-              <> help "Enable logging daily server statistics"
-          )
-      signAlgorithm <-
-        option
-          (maybeReader readMaybe)
-          ( long "sign-algorithm"
-              <> short 'a'
-              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
-              <> value ED448
-              <> showDefault
-              <> metavar "ALG"
-          )
-      ip <-
-        strOption
-          ( long "ip"
-              <> help
-                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
-              <> value "127.0.0.1"
-              <> showDefault
-              <> metavar "IP"
-          )
-      fqdn <-
-        (optional . strOption)
-          ( long "fqdn"
-              <> short 'n'
-              <> help "Server FQDN used as Common Name for TLS online certificate"
-              <> showDefault
-              <> metavar "FQDN"
-          )
-      password <-
-        flag' Nothing (long "no-password" <> help "Allow creating new queues without password")
-          <|> Just
-            <$> option
-              parseBasicAuth
-              ( long "password"
-                  <> metavar "PASSWORD"
-                  <> help "Set password to create new messaging queues"
-                  <> value SPRandom
-              )
-      scripted <-
-        switch
-          ( long "yes"
-              <> short 'y'
-              <> help "Non-interactive initialization using command-line options"
-          )
-      pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
-    parseBasicAuth :: ReadM ServerPassword
-    parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack

src/Simplex/Messaging/Server/MsgStore.hs

@@ -1,16 +1,43 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
-import Control.Applicative ((<|>))
+import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime)
+import Numeric.Natural
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (Message (..), RcvMessage (..), RecipientId)
+import Simplex.Messaging.Protocol (MsgBody, MsgFlags, MsgId, RecipientId)
 
-data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
+data Message = Message
+  { msgId :: MsgId,
+    ts :: SystemTime,
+    msgFlags :: MsgFlags,
+    msgBody :: MsgBody
+  }
+
+instance StrEncoding Message where
+  strEncode Message {msgId, ts, msgFlags, msgBody} = strEncode (msgId, ts, msgFlags, msgBody)
+  strP = do
+    (msgId, ts, msgFlags, msgBody) <- strP
+    pure Message {msgId, ts, msgFlags, msgBody}
+
+data MsgLogRecord = MsgLogRecord RecipientId Message
 
 instance StrEncoding MsgLogRecord where
-  strEncode = \case
-    MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
-    MLRv1 rId msg -> strEncode (rId, msg)
-  strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
+  strEncode (MsgLogRecord rId msg) = strEncode (rId, msg)
+  strP = MsgLogRecord <$> strP_ <*> strP
+
+class MonadMsgStore s q m | s -> q where
+  getMsgQueue :: s -> RecipientId -> Natural -> m q
+  delMsgQueue :: s -> RecipientId -> m ()
+  flushMsgQueue :: s -> RecipientId -> m [Message]
+
+class MonadMsgQueue q m where
+  isFull :: q -> m Bool
+  writeMsg :: q -> Message -> m () -- non blocking
+  tryPeekMsg :: q -> m (Maybe Message) -- non blocking
+  peekMsg :: q -> m Message -- blocking
+  tryDelMsg :: q -> MsgId -> m Bool -- non blocking
+  tryDelPeekMsg :: q -> MsgId -> m (Bool, Maybe Message) -- atomic delete (== read) last and peek next message, if available
+  deleteExpiredMsgs :: q -> Int64 -> m ()

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

@@ -1,120 +1,82 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TupleSections #-}
 
-module Simplex.Messaging.Server.MsgStore.STM
-  ( STMMsgStore,
-    MsgQueue (..),
-    newMsgStore,
-    getMsgQueue,
-    delMsgQueue,
-    flushMsgQueue,
-    writeMsg,
-    tryPeekMsg,
-    peekMsg,
-    tryDelMsg,
-    tryDelPeekMsg,
-    deleteExpiredMsgs,
-  )
-where
+module Simplex.Messaging.Server.MsgStore.STM where
 
-import Control.Concurrent.STM.TQueue (flushTQueue)
+import Control.Concurrent.STM.TBQueue (flushTBQueue)
 import Control.Monad (when)
-import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (systemSeconds))
-import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
+import Numeric.Natural
+import Simplex.Messaging.Protocol (MsgId, RecipientId)
+import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import UnliftIO.STM
 
-data MsgQueue = MsgQueue
-  { msgQueue :: TQueue Message,
-    quota :: Int,
-    canWrite :: TVar Bool,
-    size :: TVar Int
-  }
+newtype MsgQueue = MsgQueue {msgQueue :: TBQueue Message}
 
 type STMMsgStore = TMap RecipientId MsgQueue
 
 newMsgStore :: STM STMMsgStore
 newMsgStore = TM.empty
 
-getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue
-getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
-  where
-    newQ = do
-      msgQueue <- newTQueue
-      canWrite <- newTVar True
-      size <- newTVar 0
-      let q = MsgQueue {msgQueue, quota, canWrite, size}
-      TM.insert rId q st
-      pure q
+instance MonadMsgStore STMMsgStore MsgQueue STM where
+  getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
+  getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
+    where
+      newQ = do
+        q <- MsgQueue <$> newTBQueue quota
+        TM.insert rId q st
+        return q
 
-delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-delMsgQueue st rId = TM.delete rId st
+  delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
+  delMsgQueue st rId = TM.delete rId st
 
-flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
-flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
+  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
 
-writeMsg :: MsgQueue -> Message -> STM (Maybe Message)
-writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
-  canWrt <- readTVar canWrite
-  empty <- isEmptyTQueue q
-  if canWrt || empty
-    then do
-      canWrt' <- (quota >) <$> readTVar size
-      writeTVar canWrite $! canWrt'
-      modifyTVar' size (+ 1)
-      if canWrt'
-        then writeTQueue q msg $> Just msg
-        else writeTQueue q msgQuota $> Nothing
-    else pure Nothing
-  where
-    msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+instance MonadMsgQueue MsgQueue STM where
+  isFull :: MsgQueue -> STM Bool
+  isFull = isFullTBQueue . msgQueue
 
-tryPeekMsg :: MsgQueue -> STM (Maybe Message)
-tryPeekMsg = tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsg #-}
+  writeMsg :: MsgQueue -> Message -> STM ()
+  writeMsg = writeTBQueue . msgQueue
 
-peekMsg :: MsgQueue -> STM Message
-peekMsg = peekTQueue . msgQueue
-{-# INLINE peekMsg #-}
+  tryPeekMsg :: MsgQueue -> STM (Maybe Message)
+  tryPeekMsg = tryPeekTBQueue . msgQueue
 
-tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message)
-tryDelMsg mq msgId' =
-  tryPeekMsg mq >>= \case
-    msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
-      | otherwise -> pure Nothing
-    _ -> pure Nothing
+  peekMsg :: MsgQueue -> STM Message
+  peekMsg = peekTBQueue . msgQueue
 
--- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
-tryDelPeekMsg mq msgId' =
-  tryPeekMsg mq >>= \case
-    msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
-      | otherwise -> pure (Nothing, msg_)
-    _ -> pure (Nothing, Nothing)
+  tryDelMsg :: MsgQueue -> MsgId -> STM Bool
+  tryDelMsg (MsgQueue q) msgId' =
+    tryPeekTBQueue q >>= \case
+      Just Message {msgId}
+        | msgId == msgId' -> tryReadTBQueue q $> True
+        | otherwise -> pure False
+      _ -> pure False
 
-deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
-deleteExpiredMsgs mq old = loop
-  where
-    loop = tryPeekMsg mq >>= mapM_ delOldMsg
-    delOldMsg = \case
-      Message {msgTs} ->
-        when (systemSeconds msgTs < old) $
-          tryDeleteMsg mq >> loop
-      _ -> pure ()
+  -- atomic delete (== read) last and peek next message if available
+  tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
+  tryDelPeekMsg (MsgQueue q) msgId' =
+    tryPeekTBQueue q >>= \case
+      msg_@(Just Message {msgId})
+        | msgId == msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
+        | otherwise -> pure (False, msg_)
+      _ -> pure (False, Nothing)
 
-tryDeleteMsg :: MsgQueue -> STM ()
-tryDeleteMsg MsgQueue {msgQueue = q, size} =
-  tryReadTQueue q >>= \case
-    Just _ -> modifyTVar' size (subtract 1)
-    _ -> pure ()
+  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+  deleteExpiredMsgs (MsgQueue q) old = loop
+    where
+      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
+      delOldMsg Message {ts} =
+        when (systemSeconds ts < old) $
+          tryReadTBQueue q >> loop

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,35 +1,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.QueueStore where
 
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
-  { recipientId :: !RecipientId,
-    recipientKey :: !RcvPublicVerifyKey,
-    rcvDhSecret :: !RcvDhSecret,
-    senderId :: !SenderId,
-    senderKey :: !(Maybe SndPublicVerifyKey),
-    notifier :: !(Maybe NtfCreds),
-    status :: !ServerQueueStatus
+  { recipientId :: RecipientId,
+    recipientKey :: RcvPublicVerifyKey,
+    rcvDhSecret :: RcvDhSecret,
+    senderId :: SenderId,
+    senderKey :: Maybe SndPublicVerifyKey,
+    notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
+    status :: QueueStatus
   }
   deriving (Eq, Show)
 
-data NtfCreds = NtfCreds
-  { notifierId :: !NotifierId,
-    notifierKey :: !NtfPublicVerifyKey,
-    rcvNtfDhSecret :: !RcvNtfDhSecret
-  }
-  deriving (Eq, Show)
+data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
 
-instance StrEncoding NtfCreds where
-  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
-  strP = do
-    (notifierId, notifierKey, rcvNtfDhSecret) <- strP
-    pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
-
-data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
+class MonadQueueStore s m where
+  addQueue :: s -> QueueRec -> m (Either ErrorType ())
+  getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec)
+  secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec)
+  addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec)
+  suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
+  deleteQueue :: s -> RecipientId -> m (Either ErrorType ())

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,18 +10,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Simplex.Messaging.Server.QueueStore.STM
-  ( QueueStore (..),
-    newQueueStore,
-    addQueue,
-    getQueue,
-    secureQueue,
-    addQueueNotifier,
-    deleteQueueNotifier,
-    suspendQueue,
-    deleteQueue,
-  )
-where
+module Simplex.Messaging.Server.QueueStore.STM where
 
 import Control.Monad
 import Data.Functor (($>))
@@ -44,65 +34,57 @@ newQueueStore = do
   notifiers <- TM.empty
   pure QueueStore {queues, senders, notifiers}
 
-addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
-addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
-  ifM hasId (pure $ Left DUPLICATE_) $ do
-    qVar <- newTVar q
-    TM.insert rId qVar queues
-    TM.insert sId rId senders
-    pure $ Right ()
-  where
-    hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
+instance MonadQueueStore QueueStore STM where
+  addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
+  addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
+    ifM hasId (pure $ Left DUPLICATE_) $ do
+      qVar <- newTVar q
+      TM.insert rId qVar queues
+      TM.insert sId rId senders
+      pure $ Right ()
+    where
+      hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
 
-getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
-getQueue QueueStore {queues, senders, notifiers} party qId =
-  toResult <$> (mapM readTVar =<< getVar)
-  where
-    getVar = case party of
-      SRecipient -> TM.lookup qId queues
-      SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
-      SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
+  getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
+  getQueue QueueStore {queues, senders, notifiers} party qId =
+    toResult <$> (mapM readTVar =<< getVar)
+    where
+      getVar = case party of
+        SRecipient -> TM.lookup qId queues
+        SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
+        SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
 
-secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
-secureQueue QueueStore {queues} rId sKey =
-  withQueue rId queues $ \qVar ->
-    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'
+  secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
+  secureQueue QueueStore {queues} rId sKey =
+    withQueue rId queues $ \qVar ->
+      readTVar qVar >>= \q -> case senderKey q of
+        Just _ -> pure Nothing
+        _ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
 
-addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
-addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
-  ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
-    withQueue rId queues $ \qVar -> do
-      q <- readTVar qVar
-      forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
-      writeTVar qVar $! q {notifier = Just ntfCreds}
-      TM.insert nId rId notifiers
-      pure $ Just q
+  addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)
+  addQueueNotifier QueueStore {queues, notifiers} rId nId nKey = do
+    ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
+      withQueue rId queues $ \qVar ->
+        readTVar qVar >>= \q -> case notifier q of
+          Just _ -> pure Nothing
+          _ -> do
+            writeTVar qVar q {notifier = Just (nId, nKey)}
+            TM.insert nId rId notifiers
+            pure $ Just q
 
-deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-deleteQueueNotifier QueueStore {queues, notifiers} rId =
-  withQueue rId queues $ \qVar -> do
-    q <- readTVar qVar
-    forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-    writeTVar qVar $! q {notifier = Nothing}
-    pure $ Just ()
+  suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+  suspendQueue QueueStore {queues} rId =
+    withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
 
-suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-suspendQueue QueueStore {queues} rId =
-  withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
-
-deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-deleteQueue QueueStore {queues, senders, notifiers} rId = 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 ()
-    _ -> pure $ Left AUTH
+  deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+  deleteQueue QueueStore {queues, senders, notifiers} rId = do
+    TM.lookupDelete rId queues >>= \case
+      Just qVar ->
+        readTVar qVar >>= \q -> do
+          TM.delete (senderId q) senders
+          forM_ (notifier q) $ \(nId, _) -> TM.delete nId notifiers
+          pure $ Right ()
+      _ -> pure $ Left AUTH
 
 toResult :: Maybe a -> Either ErrorType a
 toResult = maybe (Left AUTH) Right

src/Simplex/Messaging/Server/Stats.hs

@@ -1,209 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Server.Stats where
-
-import Control.Applicative (optional, (<|>))
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Time.Calendar.Month.Compat (pattern MonthDay)
-import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
-import Data.Time.Clock (UTCTime (..))
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RecipientId)
-import UnliftIO.STM
-
-data ServerStats = ServerStats
-  { fromTime :: TVar UTCTime,
-    qCreated :: TVar Int,
-    qSecured :: TVar Int,
-    qDeleted :: TVar Int,
-    msgSent :: TVar Int,
-    msgRecv :: TVar Int,
-    activeQueues :: PeriodStats RecipientId,
-    msgSentNtf :: TVar Int,
-    msgRecvNtf :: TVar Int,
-    activeQueuesNtf :: PeriodStats RecipientId,
-    qCount :: TVar Int,
-    msgCount :: TVar Int
-  }
-
-data ServerStatsData = ServerStatsData
-  { _fromTime :: UTCTime,
-    _qCreated :: Int,
-    _qSecured :: Int,
-    _qDeleted :: Int,
-    _msgSent :: Int,
-    _msgRecv :: Int,
-    _activeQueues :: PeriodStatsData RecipientId,
-    _msgSentNtf :: Int,
-    _msgRecvNtf :: Int,
-    _activeQueuesNtf :: PeriodStatsData RecipientId,
-    _qCount :: Int,
-    _msgCount :: Int
-  }
-  deriving (Show)
-
-newServerStats :: UTCTime -> STM ServerStats
-newServerStats ts = do
-  fromTime <- newTVar ts
-  qCreated <- newTVar 0
-  qSecured <- newTVar 0
-  qDeleted <- newTVar 0
-  msgSent <- newTVar 0
-  msgRecv <- newTVar 0
-  activeQueues <- newPeriodStats
-  msgSentNtf <- newTVar 0
-  msgRecvNtf <- newTVar 0
-  activeQueuesNtf <- newPeriodStats
-  qCount <- newTVar 0
-  msgCount <- newTVar 0
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
-
-getServerStatsData :: ServerStats -> STM ServerStatsData
-getServerStatsData s = do
-  _fromTime <- readTVar $ fromTime s
-  _qCreated <- readTVar $ qCreated s
-  _qSecured <- readTVar $ qSecured s
-  _qDeleted <- readTVar $ qDeleted s
-  _msgSent <- readTVar $ msgSent s
-  _msgRecv <- readTVar $ msgRecv s
-  _activeQueues <- getPeriodStatsData $ activeQueues s
-  _msgSentNtf <- readTVar $ msgSentNtf s
-  _msgRecvNtf <- readTVar $ msgRecvNtf s
-  _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
-  _qCount <- readTVar $ qCount s
-  _msgCount <- readTVar $ msgCount s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
-
-setServerStats :: ServerStats -> ServerStatsData -> STM ()
-setServerStats s d = do
-  writeTVar (fromTime s) $! _fromTime d
-  writeTVar (qCreated s) $! _qCreated d
-  writeTVar (qSecured s) $! _qSecured d
-  writeTVar (qDeleted s) $! _qDeleted d
-  writeTVar (msgSent s) $! _msgSent d
-  writeTVar (msgRecv s) $! _msgRecv d
-  setPeriodStats (activeQueues s) (_activeQueues d)
-  writeTVar (msgSentNtf s) $! _msgSentNtf d
-  writeTVar (msgRecvNtf s) $! _msgRecvNtf d
-  setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
-  writeTVar (qCount s) $! _qCount d
-  writeTVar (msgCount s) $! _qCount d
-
-instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =
-    B.unlines
-      [ "fromTime=" <> strEncode _fromTime,
-        "qCreated=" <> strEncode _qCreated,
-        "qSecured=" <> strEncode _qSecured,
-        "qDeleted=" <> strEncode _qDeleted,
-        "msgSent=" <> strEncode _msgSent,
-        "msgRecv=" <> strEncode _msgRecv,
-        "msgSentNtf=" <> strEncode _msgSentNtf,
-        "msgRecvNtf=" <> strEncode _msgRecvNtf,
-        "activeQueues:",
-        strEncode _activeQueues,
-        "activeQueuesNtf:",
-        strEncode _activeQueuesNtf
-      ]
-  strP = do
-    _fromTime <- "fromTime=" *> strP <* A.endOfLine
-    _qCreated <- "qCreated=" *> strP <* A.endOfLine
-    _qSecured <- "qSecured=" *> strP <* A.endOfLine
-    _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
-    _msgSent <- "msgSent=" *> strP <* A.endOfLine
-    _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    _msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0
-    _msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0
-    _activeQueues <-
-      optional ("activeQueues:" <* A.endOfLine) >>= \case
-        Just _ -> strP <* optional A.endOfLine
-        _ -> do
-          _day <- "dayMsgQueues=" *> strP <* A.endOfLine
-          _week <- "weekMsgQueues=" *> strP <* A.endOfLine
-          _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
-          pure PeriodStatsData {_day, _week, _month}
-    _activeQueuesNtf <-
-      optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
-        Just _ -> strP <* optional A.endOfLine
-        _ -> pure newPeriodStatsData
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount = 0, _msgCount = 0}
-
-data PeriodStats a = PeriodStats
-  { day :: TVar (Set a),
-    week :: TVar (Set a),
-    month :: TVar (Set a)
-  }
-
-newPeriodStats :: STM (PeriodStats a)
-newPeriodStats = do
-  day <- newTVar S.empty
-  week <- newTVar S.empty
-  month <- newTVar S.empty
-  pure PeriodStats {day, week, month}
-
-data PeriodStatsData a = PeriodStatsData
-  { _day :: Set a,
-    _week :: Set a,
-    _month :: Set a
-  }
-  deriving (Show)
-
-newPeriodStatsData :: PeriodStatsData a
-newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
-
-getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
-getPeriodStatsData s = do
-  _day <- readTVar $ day s
-  _week <- readTVar $ week s
-  _month <- readTVar $ month s
-  pure PeriodStatsData {_day, _week, _month}
-
-setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
-setPeriodStats s d = do
-  writeTVar (day s) $! _day d
-  writeTVar (week s) $! _week d
-  writeTVar (month s) $! _month d
-
-instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
-  strEncode PeriodStatsData {_day, _week, _month} =
-    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
-  strP = do
-    _day <- "day=" *> strP <* A.endOfLine
-    _week <- "week=" *> strP <* A.endOfLine
-    _month <- "month=" *> strP
-    pure PeriodStatsData {_day, _week, _month}
-
-data PeriodStatCounts = PeriodStatCounts
-  { dayCount :: String,
-    weekCount :: String,
-    monthCount :: String
-  }
-
-periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
-periodStatCounts ps ts = do
-  let d = utctDay ts
-      (_, wDay) = mondayStartWeek d
-      MonthDay _ mDay = d
-  dayCount <- periodCount 1 $ day ps
-  weekCount <- periodCount wDay $ week ps
-  monthCount <- periodCount mDay $ month ps
-  pure PeriodStatCounts {dayCount, weekCount, monthCount}
-  where
-    periodCount :: Int -> TVar (Set a) -> STM String
-    periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
-    periodCount _ _ = pure ""
-
-updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
-updatePeriodStats stats pId = do
-  updatePeriod day
-  updatePeriod week
-  updatePeriod month
-  where
-    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)

src/Simplex/Messaging/Server/StoreLog.hs

@@ -13,13 +13,10 @@ module Simplex.Messaging.Server.StoreLog
     openReadStoreLog,
     storeLogFilePath,
     closeStoreLog,
-    writeStoreLogRecord,
     logCreateQueue,
     logSecureQueue,
     logAddNotifier,
-    logSuspendQueue,
     logDeleteQueue,
-    logDeleteNotifier,
     readWriteStoreLog,
   )
 where
@@ -37,7 +34,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
+import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..))
 import Simplex.Messaging.Transport (trimCR)
 import System.Directory (doesFileExist)
 import System.IO
@@ -51,10 +48,8 @@ data StoreLog (a :: IOMode) where
 data StoreLogRecord
   = CreateQueue QueueRec
   | SecureQueue QueueId SndPublicVerifyKey
-  | AddNotifier QueueId NtfCreds
-  | SuspendQueue QueueId
+  | AddNotifier QueueId NotifierId NtfPublicVerifyKey
   | DeleteQueue QueueId
-  | DeleteNotifier QueueId
 
 instance StrEncoding QueueRec where
   strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
@@ -67,7 +62,7 @@ instance StrEncoding QueueRec where
       ]
       <> maybe "" notifierStr notifier
     where
-      notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
+      notifierStr (nId, nKey) = " nid=" <> strEncode nId <> " nk=" <> strEncode nKey
 
   strP = do
     recipientId <- "rid=" *> strP_
@@ -75,31 +70,24 @@ instance StrEncoding QueueRec where
     rcvDhSecret <- "rdh=" *> strP_
     senderId <- "sid=" *> strP_
     senderKey <- "sk=" *> strP
-    notifier <- optional $ " notifier=" *> strP
+    notifier <- optional $ (,) <$> (" nid=" *> strP_) <*> ("nk=" *> strP)
     pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive}
 
 instance StrEncoding StoreLogRecord where
   strEncode = \case
     CreateQueue q -> strEncode (Str "CREATE", q)
     SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
-    AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
-    SuspendQueue rId -> strEncode (Str "SUSPEND", rId)
+    AddNotifier rId nId nKey -> strEncode (Str "NOTIFIER", rId, nId, nKey)
     DeleteQueue rId -> strEncode (Str "DELETE", rId)
-    DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
 
   strP =
     "CREATE " *> (CreateQueue <$> strP)
       <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
-      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
-      <|> "SUSPEND " *> (SuspendQueue <$> strP)
+      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP_ <*> strP)
       <|> "DELETE " *> (DeleteQueue <$> strP)
-      <|> "NDELETE " *> (DeleteNotifier <$> strP)
 
 openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
-openWriteStoreLog f = do
-  h <- openFile f WriteMode
-  hSetBuffering h LineBuffering
-  pure $ WriteStoreLog f h
+openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
 
 openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
 openReadStoreLog f = do
@@ -116,7 +104,7 @@ closeStoreLog = \case
   WriteStoreLog _ h -> hClose h
   ReadStoreLog _ h -> hClose h
 
-writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
+writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO ()
 writeStoreLogRecord (WriteStoreLog _ h) r = do
   B.hPutStrLn h $ strEncode r
   hFlush h
@@ -127,18 +115,12 @@ logCreateQueue s = writeStoreLogRecord s . CreateQueue
 logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
 logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
 
-logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO ()
-logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds
-
-logSuspendQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
-logSuspendQueue s = writeStoreLogRecord s . SuspendQueue
+logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NtfPublicVerifyKey -> IO ()
+logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey
 
 logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 
-logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
-logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
-
 readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
 readWriteStoreLog s@(ReadStoreLog f _) = do
   qs <- readQueues s
@@ -167,9 +149,7 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo
     procLogRecord m = \case
       CreateQueue q -> M.insert (recipientId q) q m
       SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
-      AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
-      SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
+      AddNotifier qId nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m
       DeleteQueue qId -> M.delete qId m
-      DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
     printError :: LogParsingError -> IO ()
     printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/TMap.hs

@@ -2,7 +2,6 @@ module Simplex.Messaging.TMap
   ( TMap,
     empty,
     singleton,
-    clear,
     Simplex.Messaging.TMap.null,
     Simplex.Messaging.TMap.lookup,
     member,
@@ -32,10 +31,6 @@ singleton :: k -> a -> STM (TMap k a)
 singleton k v = newTVar $ M.singleton k v
 {-# INLINE singleton #-}
 
-clear :: TMap k a -> STM ()
-clear m = writeTVar m M.empty
-{-# INLINE clear #-}
-
 null :: TMap k a -> STM Bool
 null m = M.null <$> readTVar m
 {-# INLINE null #-}

src/Simplex/Messaging/Transport.hs

@@ -28,7 +28,6 @@ module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
     supportedSMPServerVRange,
     simplexMQVersion,
-    smpBlockSize,
 
     -- * Transport connection class
     Transport (..),
@@ -47,15 +46,12 @@ module Simplex.Messaging.Transport
     -- * SMP transport
     THandle (..),
     TransportError (..),
-    HandshakeError (..),
     smpServerHandshake,
     smpClientHandshake,
     tPutBlock,
     tGetBlock,
     serializeTransportError,
     transportErrorP,
-    sendHandshake,
-    getHandshake,
 
     -- * Trim trailing CR
     trimCR,
@@ -75,14 +71,12 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
 import Data.Default (def)
 import Data.Functor (($>))
-import Data.Version (showVersion)
 import GHC.Generics (Generic)
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Generic.Random (genericArbitraryU)
 import Network.Socket
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
-import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
@@ -99,10 +93,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 5
+supportedSMPServerVRange = mkVersionRange 1 2
 
 simplexMQVersion :: String
-simplexMQVersion = showVersion SMQ.version
+simplexMQVersion = "2.3.1"
 
 -- * Transport connection class
 
@@ -156,14 +150,12 @@ data TLS = TLS
     getLock :: TMVar ()
   }
 
-connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
-connectTLS host_ logErrors params sock =
-  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
-    logHandshakeErrors (T.handshake ctx) $> ctx
-  where
-    logHandshakeErrors = if logErrors then (`catchAll` logThrow) else id
-    logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
-    host = maybe "" (\h -> " (" <> h <> ")") host_
+connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
+connectTLS params sock =
+  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
+    T.handshake ctx
+      `catchAll` \e -> putStrLn ("exception: " <> show e) >> E.throwIO e
+    pure ctx
 
 getTLS :: TransportPeer -> T.Context -> IO TLS
 getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
@@ -216,7 +208,7 @@ instance Transport TLS where
       $ do
         b <- readChunks =<< readTVarIO buffer
         let (s, b') = B.splitAt n b
-        atomically $ writeTVar buffer $! b'
+        atomically $ writeTVar buffer b'
         pure s
     where
       readChunks :: ByteString -> IO ByteString
@@ -239,7 +231,7 @@ instance Transport TLS where
       $ do
         b <- readChunks =<< readTVarIO buffer
         let (s, b') = B.break (== '\n') b
-        atomically $ writeTVar buffer $! B.drop 1 b' -- drop '\n' we made a break at
+        atomically $ writeTVar buffer (B.drop 1 b') -- drop '\n' we made a break at
         pure $ trimCR s
     where
       readChunks :: ByteString -> IO ByteString
@@ -263,10 +255,7 @@ data THandle c = THandle
     sessionId :: SessionId,
     blockSize :: Int,
     -- | agreed server protocol version
-    thVersion :: Version,
-    -- | send multiple transmissions in a single block
-    -- based on protocol and protocol version
-    batch :: Bool
+    thVersion :: Version
   }
 
 -- | TLS-unique channel binding
@@ -372,7 +361,7 @@ smpServerHandshake c kh smpVRange = do
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
       | smpVersion `isCompatible` smpVRange -> do
-        pure $ smpThHandle th smpVersion
+        pure (th :: THandle c) {thVersion = smpVersion}
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
@@ -387,12 +376,9 @@ smpClientHandshake c keyHash smpVRange = do
     else case smpVersionRange `compatibleVersion` smpVRange of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure $ smpThHandle th smpVersion
+        pure (th :: THandle c) {thVersion = smpVersion}
       Nothing -> throwE $ TEHandshake VERSION
 
-smpThHandle :: forall c. THandle c -> Version -> THandle c
-smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
-
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
@@ -400,4 +386,4 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr
 getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
 smpTHandle :: Transport c => c -> THandle c
-smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}
+smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}

src/Simplex/Messaging/Transport/Client.hs

@@ -1,135 +1,44 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Client
   ( runTransportClient,
     runTLSTransportClient,
     smpClientHandshake,
-    defaultSMPPort,
-    defaultTransportClientConfig,
-    defaultSocksProxy,
-    TransportClientConfig (..),
-    SocksProxy,
-    TransportHost (..),
-    TransportHosts (..),
-    TransportHosts_ (..),
   )
 where
 
-import Control.Applicative (optional)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Default (def)
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as L
-import Data.Maybe (fromMaybe)
-import Data.String
-import Data.Word (Word8)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import GHC.IO.Exception (IOErrorType (..))
 import Network.Socket
-import Network.Socks5
 import qualified Network.TLS as T
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util (bshow, (<$?>))
 import System.IO.Error
-import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
-data TransportHost
-  = THIPv4 (Word8, Word8, Word8, Word8)
-  | THOnionHost ByteString
-  | THDomainName HostName
-  deriving (Eq, Ord, Show)
-
-instance Encoding TransportHost where
-  smpEncode = smpEncode . strEncode
-  smpP = parseAll strP <$?> smpP
-
-instance StrEncoding TransportHost where
-  strEncode = \case
-    THIPv4 (a1, a2, a3, a4) -> B.intercalate "." $ map bshow [a1, a2, a3, a4]
-    THOnionHost host -> host
-    THDomainName host -> B.pack host
-  strP =
-    A.choice
-      [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
-        THOnionHost <$> ((<>) <$> A.takeTill (== '.') <*> A.string ".onion"),
-        THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      ]
-    where
-      ipNum = A.decimal <* A.char '.'
-
-instance ToJSON TransportHost where
-  toEncoding = strToJEncoding
-  toJSON = strToJSON
-
-newtype TransportHosts = TransportHosts {thList :: NonEmpty TransportHost}
-
-instance StrEncoding TransportHosts where
-  strEncode = strEncodeList . L.toList . thList
-  strP = TransportHosts . L.fromList <$> strP `A.sepBy1'` A.char ','
-
-newtype TransportHosts_ = TransportHosts_ {thList_ :: [TransportHost]}
-
-instance StrEncoding TransportHosts_ where
-  strEncode = strEncodeList . thList_
-  strP = TransportHosts_ <$> strP `A.sepBy'` A.char ','
-
-instance IsString TransportHost where fromString = parseString strDecode
-
-instance IsString (NonEmpty TransportHost) where fromString = parseString strDecode
-
-data TransportClientConfig = TransportClientConfig
-  { socksProxy :: Maybe SocksProxy,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    logTLSErrors :: Bool
-  }
-  deriving (Eq, Show)
-
-defaultTransportClientConfig :: TransportClientConfig
-defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
-
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} host port keyHash client = do
-  let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
-      connectTCP = case socksProxy of
-        Just proxy -> connectSocksClient proxy $ hostAddr host
-        _ -> connectTCPClient hostName
-  c <- liftIO $ do
-    sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) tcpKeepAlive
-    connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do
+  let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
+  c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
   client c `E.finally` liftIO (closeConnection c)
-  where
-    hostAddr = \case
-      THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
-      THOnionHost h -> SocksAddrDomainName h
-      THDomainName h -> SocksAddrDomainName $ B.pack h
 
-connectTCPClient :: HostName -> ServiceName -> IO Socket
-connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
+startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -139,52 +48,20 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
       let hints = defaultHints {addrSocketType = Stream}
        in getAddrInfo (Just hints) (Just host) (Just port)
 
-    tryOpen :: IOException -> [AddrInfo] -> IO Socket
+    tryOpen :: IOException -> [AddrInfo] -> IO c
     tryOpen e [] = E.throwIO e
     tryOpen _ (addr : as) =
       E.try (open addr) >>= either (`tryOpen` as) pure
 
-    open :: AddrInfo -> IO Socket
+    open :: AddrInfo -> IO c
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      pure sock
+      mapM_ (setSocketKeepAlive sock) keepAliveOpts
+      ctx <- connectTLS clientParams sock
+      getClientConnection ctx
 
-defaultSMPPort :: PortNumber
-defaultSMPPort = 5223
-
-connectSocksClient :: SocksProxy -> SocksHostAddress -> ServiceName -> IO Socket
-connectSocksClient (SocksProxy addr) hostAddr _port = do
-  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
-  fst <$> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
-
-defaultSocksHost :: HostAddress
-defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
-
-defaultSocksProxy :: SocksProxy
-defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
-
-newtype SocksProxy = SocksProxy SockAddr
-  deriving (Eq)
-
-instance Show SocksProxy where show (SocksProxy addr) = show addr
-
-instance StrEncoding SocksProxy where
-  strEncode = B.pack . show
-  strP = do
-    host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
-    port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
-    pure . SocksProxy $ SockAddrInet port host
-    where
-      ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
-      ipNum = A.decimal <* A.char '.'
-
-instance ToJSON SocksProxy where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-instance FromJSON SocksProxy where
-  parseJSON = strParseJSON "SocksProxy"
+-- readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
 
 mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
 mkTLSClientParams supported caStore_ host port keyHash_ = do
@@ -207,7 +84,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_,
     x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
       where
         hooks = XV.defaultHooks
-        checks = XV.defaultChecks {XV.checkFQHN = False}
+        checks = XV.defaultChecks
         certStore = XS.makeCertificateStore sc
         cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
         serviceID = (host, port)

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

@@ -19,13 +19,14 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
+import Simplex.Messaging.Transport.Client (runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
+import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
 import UnliftIO.STM
 import UnliftIO.Timeout
 
 data HTTP2Client = HTTP2Client
-  { action :: Maybe (Async ()),
+  { action :: Async (),
     connected :: TVar Bool,
     host :: HostName,
     port :: ServiceName,
@@ -42,7 +43,7 @@ data HTTP2Response = HTTP2Response
 data HTTP2ClientConfig = HTTP2ClientConfig
   { qSize :: Natural,
     connTimeout :: Int,
-    transportConfig :: TransportClientConfig,
+    tcpKeepAlive :: Maybe KeepAliveOpts,
     caStoreFile :: FilePath,
     suportedTLSParams :: T.Supported
   }
@@ -53,7 +54,7 @@ defaultHTTP2ClientConfig =
   HTTP2ClientConfig
     { qSize = 64,
       connTimeout = 10000000,
-      transportConfig = TransportClientConfig Nothing Nothing True,
+      tcpKeepAlive = Nothing,
       caStoreFile = "/etc/ssl/cert.pem",
       suportedTLSParams = http2TLSParams
     }
@@ -62,7 +63,7 @@ data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | H
   deriving (Show)
 
 getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout, caStoreFile, suportedTLSParams} disconnected =
+getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
   (atomically mkHTTPS2Client >>= runClient)
     `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
   where
@@ -70,7 +71,7 @@ getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout,
     mkHTTPS2Client = do
       connected <- newTVar False
       reqQ <- newTBQueue $ qSize config
-      pure HTTP2Client {action = Nothing, connected, host, port, config, reqQ}
+      pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
 
     runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
@@ -79,11 +80,11 @@ getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout,
       when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
       action <-
         async $
-          runHTTP2Client suportedTLSParams caStore transportConfig host port (client c cVar)
+          runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
             `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
       conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
       pure $ case conn_ of
-        Just (Right ()) -> Right c {action = Just action}
+        Just (Right ()) -> Right c {action}
         Just (Left e) -> Left e
         Nothing -> Left HCNetworkError1
 
@@ -110,7 +111,8 @@ getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout,
 
 -- | Disconnects client from the server and terminates client threads.
 closeHTTP2Client :: HTTP2Client -> IO ()
-closeHTTP2Client = mapM_ uninterruptibleCancel . action
+-- TODO disconnect
+closeHTTP2Client = uninterruptibleCancel . action
 
 sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
 sendRequest HTTP2Client {reqQ, config} req = do
@@ -118,9 +120,9 @@ sendRequest HTTP2Client {reqQ, config} req = do
   atomically $ writeTBQueue reqQ (req, resp)
   maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
 
-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> HostName -> ServiceName -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTP2Client tlsParams caStore tcConfig host port client =
-  runTLSTransportClient tlsParams caStore tcConfig (THDomainName host) port Nothing $ \c ->
+runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
+runHTTP2Client tlsParams caStore host port keepAliveOpts client =
+  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
     withTlsConfig c 16384 (`run` client)
   where
     run = H.run $ ClientConfig "https" (B.pack host) 20

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

@@ -25,8 +25,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig
     serverSupported :: T.Supported,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath,
-    logTLSErrors :: Bool
+    certificateFile :: FilePath
   }
   deriving (Show)
 
@@ -43,12 +42,12 @@ data HTTP2Server = HTTP2Server
   }
 
 getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
   tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port tlsServerParams logTLSErrors $ \r sendResponse -> do
+    runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
       reqBody <- getRequestBody r ""
       reqTrailers <- H.getRequestTrailers r
       atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
@@ -63,9 +62,9 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertifica
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port serverParams logTLSErrors http2Server =
-  runTransportServer started port serverParams logTLSErrors $ \c -> withTlsConfig c 16384 (`H.run` server)
+runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port serverParams http2Server =
+  runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
   where
     server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
     server req _aux sendResp = http2Server req (`sendResp` [])

src/Simplex/Messaging/Transport/KeepAlive.hs

@@ -1,15 +1,10 @@
 {-# LANGUAGE CApiFFI #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Transport.KeepAlive where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson as J
 import Foreign.C (CInt (..))
-import GHC.Generics (Generic)
 import Network.Socket
 
 data KeepAliveOpts = KeepAliveOpts
@@ -17,9 +12,7 @@ data KeepAliveOpts = KeepAliveOpts
     keepIntvl :: Int,
     keepCnt :: Int
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON KeepAliveOpts where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 defaultKeepAliveOpts :: KeepAliveOpts
 defaultKeepAliveOpts =

src/Simplex/Messaging/Transport/Server.hs

@@ -35,12 +35,12 @@ import UnliftIO.STM
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> (c -> m ()) -> m ()
-runTransportServer started port serverParams logTLSErrors server = do
+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
+runTransportServer started port serverParams server = do
   u <- askUnliftIO
   liftIO . runTCPServer started port $ \conn ->
     E.bracket
-      (connectTLS Nothing logTLSErrors serverParams conn >>= getServerConnection)
+      (connectTLS serverParams conn >>= getServerConnection)
       closeConnection
       (unliftIO u . server)
 
@@ -54,7 +54,7 @@ runTCPServer started port server = do
     (closeServer started clients)
     $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
       -- catchAll_ is needed here in case the connection was closed earlier
-      cId <- atomically $ stateTVar clientId $ \cId -> let cId' = cId + 1 in (cId', cId')
+      cId <- atomically $ stateTVar clientId $ \cId -> (cId + 1, cId + 1)
       let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
       atomically $ TM.insert cId tId clients

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -18,7 +18,6 @@ import Simplex.Messaging.Transport
     TransportError (..),
     TransportPeer (..),
     closeTLS,
-    smpBlockSize,
     trimCR,
     withTlsUnique,
   )
@@ -34,7 +33,7 @@ websocketsOpts :: ConnectionOptions
 websocketsOpts =
   defaultConnectionOptions
     { connectionCompressionOptions = NoCompression,
-      connectionFramePayloadSizeLimit = SizeLimit $ fromIntegral smpBlockSize,
+      connectionFramePayloadSizeLimit = SizeLimit $ 16 * 1024, -- TODO move to Protocol
       connectionMessageDataSizeLimit = SizeLimit 65536
     }
 

src/Simplex/Messaging/Util.hs

@@ -10,9 +10,6 @@ import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
 import UnliftIO.Async
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -35,10 +32,6 @@ bshow :: Show a => a -> ByteString
 bshow = B.pack . show
 {-# INLINE bshow #-}
 
-tshow :: Show a => a -> Text
-tshow = T.pack . show
-{-# INLINE tshow #-}
-
 maybeWord :: (a -> ByteString) -> Maybe a -> ByteString
 maybeWord f = maybe "" $ B.cons ' ' . f
 {-# INLINE maybeWord #-}
@@ -63,10 +56,6 @@ tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
 tryE m = (Right <$> m) `catchE` (pure . Left)
 {-# INLINE tryE #-}
 
-liftE :: (e -> e') -> ExceptT e IO a -> ExceptT e' IO a
-liftE f a = ExceptT $ first f <$> runExceptT a
-{-# INLINE liftE #-}
-
 ifM :: Monad m => m Bool -> m a -> m a -> m a
 ifM ba t f = ba >>= \b -> if b then t else f
 {-# INLINE ifM #-}
@@ -93,8 +82,3 @@ catchAll_ a = catchAll a . const
 eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
-
-safeDecodeUtf8 :: ByteString -> Text
-safeDecodeUtf8 = decodeUtf8With onError
-  where
-    onError _ _ = Just '?'

src/Simplex/Messaging/Version.hs

@@ -15,7 +15,6 @@ module Simplex.Messaging.Version
     pattern Compatible,
     mkVersionRange,
     safeVersionRange,
-    versionToRange,
     isCompatible,
     proveCompatible,
     compatibleVersion,
@@ -54,9 +53,6 @@ safeVersionRange v1 v2
   | v1 <= v2 = Just $ VRange v1 v2
   | otherwise = Nothing
 
-versionToRange :: Version -> VersionRange
-versionToRange v = VRange v v
-
 instance Encoding VersionRange where
   smpEncode (VRange v1 v2) = smpEncode (v1, v2)
   smpP =

stack.yaml

@@ -39,7 +39,7 @@ extra-deps:
   - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
   - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987
-  # below dependencies are to update Aeson to 2.0.3
+  # below dependancies are to update Aeson to 2.0.3
   - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
   - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
   - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005
@@ -48,12 +48,6 @@ extra-deps:
   - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
   - github: simplex-chat/aeson
     commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
-  # - ../direct-sqlcipher
-  - github: simplex-chat/direct-sqlcipher
-    commit: 34309410eb2069b029b8fc1872deb1e0db123294
-  # - ../sqlcipher-simple
-  - github: simplex-chat/sqlcipher-simple
-    commit: 5e154a2aeccc33ead6c243ec07195ab673137221
   # - ../hs-tls/core
   # - github: simplex-chat/hs-tls
   #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e

tests/AgentTests.hs

@@ -22,7 +22,6 @@ import qualified Data.ByteString.Char8 as B
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
 import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
-import Simplex.Messaging.Agent.Env.SQLite (AgentDatabase, databaseFile)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Encoding.String
@@ -30,6 +29,8 @@ import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
 import Simplex.Messaging.Util (bshow)
 import System.Directory (removeFile)
+import System.Posix.Files (stdFileMode)
+import System.Posix.Semaphore (OpenSemFlags (..), semOpen, semPost, semThreadWait)
 import System.Timeout
 import Test.Hspec
 
@@ -43,6 +44,7 @@ agentTests (ATransport t) = do
   describe "SQLite schema dump" schemaDumpTest
   describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection" $ do
+    it "test semaphore" testSemaphore
     it "should connect via one server and one agent" $
       smpAgentTest2_1_1 $ testDuplexConnection t
     it "should connect via one server and one agent (random IDs)" $
@@ -78,20 +80,10 @@ agentTests (ATransport t) = do
       smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
     it "should deliver messages if one of connections has quota exceeded" $
       smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
-    it "should resume delivering messages after exceeding quota once all messages are received" $
-      smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
-
-tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-tGetAgent h = do
-  t@(_, _, cmd) <- tGet SAgent h
-  case cmd of
-    Right CONNECT {} -> tGetAgent h
-    Right DISCONNECT {} -> tGetAgent h
-    _ -> pure t
 
 -- | receive message to handle `h`
 (<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-(<#:) = tGetAgent
+(<#:) = tGet SAgent
 
 -- | send transmission `t` to handle `h` and get response
 (#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
@@ -125,19 +117,25 @@ h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 h #:# err = tryGet `shouldReturn` ()
   where
     tryGet =
-      10000 `timeout` tGetAgent h >>= \case
+      10000 `timeout` tGet SAgent h >>= \case
         Just _ -> error err
         _ -> return ()
 
 pattern Msg :: MsgBody -> ACommand 'Agent
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
+testSemaphore :: IO ()
+testSemaphore = do
+  sem <- semOpen "/test" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 1
+  semThreadWait sem
+  semPost sem
+
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
-  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV")
+  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   bob <# ("", "alice", INFO "alice's connInfo")
   bob <# ("", "alice", CON)
@@ -167,10 +165,10 @@ testDuplexConnection _ alice bob = do
 
 testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnRandomIds _ alice bob = do
-  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV")
+  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
   let cReq' = strEncode cReq
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
-  ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
+  ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
   bobConn' `shouldBe` bobConn
   alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
   bob <# ("", aliceConn, INFO "alice's connInfo")
@@ -200,13 +198,13 @@ testDuplexConnRandomIds _ alice bob = do
 
 testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testContactConnection _ alice bob tom = do
-  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON")
+  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")
   let cReq' = strEncode cReq
 
-  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-  ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
+  ("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
   bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
   alice <# ("", "bob", INFO "bob's connInfo 2")
   alice <# ("", "bob", CON)
@@ -216,10 +214,10 @@ testContactConnection _ alice bob tom = do
   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
   bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
-  tom #: ("21", "alice", "JOIN T " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:)
+  tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
   alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
-  ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:)
+  ("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
   tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
   alice <# ("", "tom", INFO "tom's connInfo 2")
   alice <# ("", "tom", CON)
@@ -231,15 +229,15 @@ testContactConnection _ alice bob tom = do
 
 testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testContactConnRandomIds _ alice bob = do
-  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON")
+  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")
   let cReq' = strEncode cReq
 
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
-  ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
+  ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
   aliceContact' `shouldBe` aliceContact
 
   ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
-  ("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
+  ("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
   aliceConn' `shouldBe` aliceConn
 
   bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
@@ -254,10 +252,10 @@ testContactConnRandomIds _ alice bob = do
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
 testRejectContactRequest _ alice bob = do
-  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON")
+  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
-  ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
+  ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)
   -- RJCT must use correct contact connection
   alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
   alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -285,7 +283,7 @@ testSubscription _ alice1 alice2 bob = do
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
 testSubscrNotification t (server, _) client = do
-  client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
+  client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
   client <# ("", "", DOWN testSMPServer ["conn1"])
@@ -333,27 +331,27 @@ testServerConnectionAfterError t _ = do
 
   withAgent1 $ \bob -> do
     withAgent2 $ \alice -> do
-      bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
-      alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
+      bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
+      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
       withServer $ do
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
+        alice <# ("", "bob", SENT 4)
         bob <# ("", "", UP server ["alice"])
         bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
         bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
+        alice <# ("", "", UP server ["bob"])
         alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
         alice <# ("", "bob", SENT 5)
         bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
 
   removeFile testStoreLogFile
-  removeFile $ databaseFile testDB
-  removeFile $ databaseFile testDB2
+  removeFile testDB
+  removeFile testDB2
   where
     server = SMPServer "localhost" testPort2 testKeyHash
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent1 = withAgent agentTestPort testDB
     withAgent2 = withAgent agentTestPort2 testDB2
-    withAgent :: String -> AgentDatabase -> (c -> IO a) -> IO a
+    withAgent :: String -> String -> (c -> IO a) -> IO a
     withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
 
 testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
@@ -386,7 +384,7 @@ testMsgDeliveryAgentRestart t bob = do
       bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
-  removeFile $ databaseFile testDB
+  removeFile testDB
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort
@@ -395,10 +393,10 @@ testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
 testConcurrentMsgDelivery _ alice bob = do
   connect (alice, "alice") (bob, "bob")
 
-  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV")
+  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice2", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
-  ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
+  ("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)
   -- below commands would be needed to accept bob's connection, but alice does not
   -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   -- bob <# ("", "alice", INFO "alice's connInfo")
@@ -432,38 +430,12 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
   -- if delivery is blocked it won't go further
   alice <# ("", "bob2", SENT 4)
 
-testResumeDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
-testResumeDeliveryQuotaExceeded _ alice bob = do
-  connect (alice, "alice") (bob, "bob")
-  forM_ [1 .. 4 :: Int] $ \i -> do
-    let corrId = bshow i
-        msg = "message " <> bshow i
-    (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
-    alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
-  ("5", "bob", Right (MID 8)) <- alice #: ("5", "bob", "SEND F :over quota")
-  alice #:# "the last message not sent yet"
-  bob <#= \case ("", "alice", Msg "message 1") -> True; _ -> False
-  bob #: ("1", "alice", "ACK 4") #> ("1", "alice", OK)
-  alice #:# "the last message not sent"
-  bob <#= \case ("", "alice", Msg "message 2") -> True; _ -> False
-  bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
-  alice #:# "the last message not sent"
-  bob <#= \case ("", "alice", Msg "message 3") -> True; _ -> False
-  bob #: ("3", "alice", "ACK 6") #> ("3", "alice", OK)
-  alice #:# "the last message not sent"
-  bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
-  bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
-  alice <# ("", "bob", SENT 8)
-  bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
-  -- message 8 is skipped because of alice agent sending "QCONT" message
-  bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
-
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
-  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV")
+  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
   let cReq' = strEncode cReq
-  h2 #: ("c2", name1, "JOIN T " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
+  h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
+  ("", _, Right (CONF connId "info2")) <- (h1 <#:)
   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
   h2 <# ("", name1, INFO "info1")
   h2 <# ("", name1, CON)
@@ -481,10 +453,10 @@ sendMessage (h1, name1) (h2, name2) msg = do
 
 -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
 -- connect' h1 h2 = do
---   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV")
+--   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
 --   let cReq' = strEncode cReq
---   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " 5\ninfo2")
---   ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
+--   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
+--   ("", _, Right (REQ connId "info2")) <- (h1 <#:)
 --   h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
 --   h2 <# ("", conn1, INFO "info1")
 --   h2 <# ("", conn1, CON)
@@ -500,17 +472,17 @@ syntaxTests t = do
   describe "NEW" $ do
     describe "valid" $ do
       -- TODO: add tests with defined connection id
-      it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
+      it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
     describe "invalid" $ do
       -- TODO: add tests with defined connection id
-      it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX")
+      it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
 
   describe "JOIN" $ do
     describe "valid" $ do
       it "using same server as in invitation" $
         ( "311",
           "a",
-          "JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
+          "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
             <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
             <> "%40localhost%3A5001%2F3456-w%3D%3D%23"
             <> urlEncode True sampleDhKey

tests/AgentTests/ConnectionRequestTests.hs

@@ -11,7 +11,7 @@ import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ProtocolServer (..), supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (ProtocolServer (..), smpClientVRange)
 import Simplex.Messaging.Version
 import Test.Hspec
 
@@ -19,24 +19,21 @@ uri :: String
 uri = "smp.simplex.im"
 
 srv :: SMPServer
-srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
-
-queueAddr :: SMPQueueAddress
-queueAddr =
-  SMPQueueAddress
-    { smpServer = srv,
-      senderId = "\223\142z\251",
-      dhPublicKey = testDhKey
+srv =
+  ProtocolServer
+    { host = "smp.simplex.im",
+      port = "5223",
+      keyHash = C.KeyHash "\215m\248\251"
     }
 
-queueAddrNoPort :: SMPQueueAddress
-queueAddrNoPort = queueAddr {smpServer = srv {port = ""}}
-
 queue :: SMPQueueUri
-queue = SMPQueueUri supportedSMPClientVRange queueAddr
-
-queueV1 :: SMPQueueUri
-queueV1 = SMPQueueUri (mkVersionRange 1 1) queueAddr
+queue =
+  SMPQueueUri
+    { smpServer = srv,
+      senderId = "\223\142z\251",
+      clientVRange = smpClientVRange,
+      dhPublicKey = testDhKey
+    }
 
 testDhKey :: C.PublicKeyX25519
 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
@@ -52,18 +49,17 @@ connReqData =
   ConnReqUriData
     { crScheme = simplexChat,
       crAgentVRange = mkVersionRange 1 1,
-      crSmpQueues = [queueV1],
-      crClientData = Nothing
+      crSmpQueues = [queue]
     }
 
 testDhPubKey :: C.PublicKeyX448
 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="
 
 testE2ERatchetParams :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange 1 1) testDhPubKey testDhPubKey
+testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhPubKey
 
-testE2ERatchetParams12 :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey
+testE2ERatchetParams13 :: E2ERatchetParamsUri 'C.X448
+testE2ERatchetParams13 = E2ERatchetParamsUri (mkVersionRange 1 3) testDhPubKey testDhPubKey
 
 connectionRequest :: AConnectionRequestUri
 connectionRequest =
@@ -74,61 +70,41 @@ connectionRequest12 :: AConnectionRequestUri
 connectionRequest12 =
   ACR SCMInvitation $
     CRInvitationUri
-      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
-      testE2ERatchetParams12
-
-connectionRequestClientDataEmpty :: AConnectionRequestUri
-connectionRequestClientDataEmpty =
-  ACR SCMInvitation $
-    CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams
-
-connectionRequestClientData :: AConnectionRequestUri
-connectionRequestClientData =
-  ACR SCMInvitation $
-    CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams
+      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
+      testE2ERatchetParams13
 
 connectionRequestTests :: Spec
 connectionRequestTests =
   describe "connection request parsing / serializing" $ do
     it "should serialize SMP queue URIs" $ do
-      strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
-        `shouldBe` "smp://[email protected]/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
+      strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+        `shouldBe` "smp://[email protected]/3456-w==#" <> testDhKeyStr
       strEncode queue {clientVRange = mkVersionRange 1 2}
-        `shouldBe` "smp://[email protected]:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
+        `shouldBe` "smp://[email protected]:5223/3456-w==#" <> testDhKeyStr
     it "should parse SMP queue URIs" $ do
-      strDecode ("smp://[email protected]/3456-w==#/?v=1-2&dh=" <> testDhKeyStr)
-        `shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
+      strDecode ("smp://[email protected]/3456-w==#/?v=1&dh=" <> testDhKeyStr)
+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
       strDecode ("smp://[email protected]/3456-w==#" <> testDhKeyStr)
-        `shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort}
+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
       strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr)
-        `shouldBe` Right queueV1
-      strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
         `shouldBe` Right queue
-      strDecode ("smp://[email protected]:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr)
-        `shouldBe` Right queueV1
       strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
-        `shouldBe` Right queueV1
+        `shouldBe` Right queue
+      strDecode ("smp://[email protected]:5223/3456-w==#/?extra_param=abc&v=1-2&dh=" <> testDhKeyStr)
+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
+      strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
     it "should serialize connection requests" $ do
       strEncode connectionRequest
-        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-        <> urlEncode True testDhKeyStrUri
+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
         <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
       strEncode connectionRequest12
-        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-        <> urlEncode True testDhKeyStrUri
-        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-        <> urlEncode True testDhKeyStrUri
-        <> "&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-      strEncode connectionRequestClientDataEmpty
-        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-        <> urlEncode True testDhKeyStrUri
-        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-        <> "&data=%7B%7D"
-      strEncode connectionRequestClientData
-        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-        <> urlEncode True testDhKeyStrUri
-        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-        <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
+        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
+        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
+        <> "&e2e=v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
     it "should parse connection requests" $ do
       strDecode
         ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
@@ -156,24 +132,8 @@ connectionRequestTests =
             <> testDhKeyStrUri
             <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
             <> testDhKeyStrUri
-            <> "&e2e=extra_key%3Dnew%26v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&e2e=extra_key%3Dnew%26v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> "&some_new_param=abc"
             <> "&v=1-2"
         )
         `shouldBe` Right connectionRequest12
-      strDecode
-        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-            <> testDhKeyStrUri
-            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-            <> "&data=%7B%7D"
-            <> "&v=1-1"
-        )
-        `shouldBe` Right connectionRequestClientDataEmpty
-      strDecode
-        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
-            <> testDhKeyStrUri
-            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-            <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
-            <> "&v=1-1"
-        )
-        `shouldBe` Right connectionRequestClientData

tests/AgentTests/DoubleRatchetTests.hs

@@ -46,9 +46,6 @@ doubleRatchetTests = do
     it "should agree the same ratchet parameters" $ do
       testX3dh C.SX25519
       testX3dh C.SX448
-    it "should agree the same ratchet parameters with version 1" $ do
-      testX3dhV1 C.SX25519
-      testX3dhV1 C.SX448
 
 paddedMsgLen :: Int
 paddedMsgLen = 100
@@ -59,7 +56,7 @@ fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen
 testMessageHeader :: Expectation
 testMessageHeader = do
   (k, _) <- C.generateKeyPair' @X25519
-  let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
+  let hdr = MsgHeader {msgMaxVersion = e2eEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
   parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr
 
 pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)
@@ -171,16 +168,8 @@ testEncodeDecode x = do
 
 testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dh _ = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a currentE2EEncryptVersion
-  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
-      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
-  paramsAlice `shouldBe` paramsBob
-
-testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
-testX3dhV1 _ = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a 1
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a 1
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a e2eEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a e2eEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   paramsAlice `shouldBe` paramsBob
@@ -200,13 +189,13 @@ withRatchets test = do
 
 initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
 initRatchets = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams currentE2EEncryptVersion
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams e2eEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams e2eEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   (_, pkBob3) <- C.generateKeyPair'
-  let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice
+  let bob = initSndRatchet (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet pkAlice2 paramsAlice
   pure (alice, bob)
 
 encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))

tests/AgentTests/FunctionalAPITests.hs

@@ -1,22 +1,13 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests
   ( functionalAPITests,
-    testServerMatrix2,
-    makeConnection,
-    exchangeGreetingsMsgId,
-    switchComplete,
-    runRight,
-    runRight_,
     get,
     (##>),
     (=##>),
@@ -24,31 +15,20 @@ module AgentTests.FunctionalAPITests
   )
 where
 
-import Control.Concurrent (killThread, threadDelay)
-import Control.Monad
-import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
+import Control.Concurrent (threadDelay)
+import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Unlift
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Int (Int64)
-import qualified Data.Map as M
-import Data.Maybe (isNothing)
-import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPAgentClient
-import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..))
+import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ATransport (..))
-import Simplex.Messaging.Util (tryError)
 import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO
@@ -60,47 +40,36 @@ a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
 get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
-get c = do
-  t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
-  case cmd of
-    CONNECT {} -> get c
-    DISCONNECT {} -> get c
-    _ -> pure t
+get c = atomically (readTBQueue $ subQ c)
 
 pattern Msg :: MsgBody -> ACommand 'Agent
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
-smpCfgV1 :: ProtocolClientConfig
-smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = vr11}
-
 agentCfgV1 :: AgentConfig
-agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1}
-
-agentCfgRatchetV1 :: AgentConfig
-agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
-
-vr11 :: VersionRange
-vr11 = mkVersionRange 1 1
-
-runRight_ :: ExceptT AgentErrorType IO () -> Expectation
-runRight_ action = runExceptT action `shouldReturn` Right ()
-
-runRight :: ExceptT AgentErrorType IO a -> IO a
-runRight action =
-  runExceptT action >>= \case
-    Right x -> pure x
-    Left e -> error $ "Unexpected error: " <> show e
+agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1}
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
   describe "Establishing duplex connection" $
-    testMatrix2 t runAgentClientTest
-  describe "Establishing duplex connection v2, different Ratchet versions" $
-    testRatchetMatrix2 t runAgentClientTest
+    it "should connect via one server using SMP agent clients" $
+      withSmpServer t testAgentClient
+  describe "Duplex connection between agent versions 1 and 2" $ do
+    it "should connect agent v1 to v1" $
+      withSmpServer t testAgentClientV1toV1
+    it "should connect agent v1 to v2" $
+      withSmpServer t testAgentClientV1toV2
+    it "should connect agent v2 to v1" $
+      withSmpServer t testAgentClientV2toV1
   describe "Establish duplex connection via contact address" $
-    testMatrix2 t runAgentClientContactTest
-  describe "Establish duplex connection via contact address v2, different Ratchet versions" $
-    testRatchetMatrix2 t runAgentClientContactTest
+    it "should connect via one server using SMP agent clients" $
+      withSmpServer t testAgentClientContact
+  describe "Duplex connection via contact address between agent versions 1 and 2" $ do
+    it "should connect agent v1 to v1" $
+      withSmpServer t testAgentClientContactV1toV1
+    it "should connect agent v1 to v2" $
+      withSmpServer t testAgentClientContactV1toV2
+    it "should connect agent v2 to v1" $
+      withSmpServer t testAgentClientContactV2toV1
   describe "Establishing connection asynchronously" $ do
     it "should connect with initiating client going offline" $
       withSmpServer t testAsyncInitiatingOffline
@@ -120,118 +89,61 @@ functionalAPITests t = do
       testInactiveClientDisconnected t
     it "should NOT disconnect active clients" $
       testActiveClientNotDisconnected t
-  describe "Suspending agent" $ do
-    it "should update client when agent is suspended" $
-      withSmpServer t testSuspendingAgent
-    it "should complete sending messages when agent is suspended" $
-      testSuspendingAgentCompleteSending t
-    it "should suspend agent on timeout, even if pending messages not sent" $
-      testSuspendingAgentTimeout t
-  describe "Batching SMP commands" $ do
-    it "should subscribe to multiple subscriptions with batching" $
-      testBatchedSubscriptions t
-  describe "Async agent commands" $ do
-    it "should connect using async agent commands" $
-      withSmpServer t testAsyncCommands
-    it "should restore and complete async commands on restart" $
-      testAsyncCommandsRestore t
-    it "should accept connection using async command" $
-      withSmpServer t testAcceptContactAsync
-  describe "Queue rotation" $ do
-    describe "should switch delivery to the new queue" $
-      testServerMatrix2 t testSwitchConnection
-    describe "should switch to new queue asynchronously" $
-      testServerMatrix2 t testSwitchAsync
-    describe "should delete connection during rotation" $
-      testServerMatrix2 t testSwitchDelete
-  describe "SMP basic auth" $ do
-    describe "with server auth" $ do
-      --                                       allow NEW | server auth, v | clnt1 auth, v  | clnt2 auth, v    |  2 - success, 1 - JOIN fail, 0 - NEW fail
-      it "success                " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
-      it "disabled               " $ testBasicAuth t False (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
-      it "NEW fail, no auth      " $ testBasicAuth t True (Just "abcd", 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 0
-      it "NEW fail, bad auth     " $ testBasicAuth t True (Just "abcd", 5) (Just "wrong", 5) (Just "abcd", 5) `shouldReturn` 0
-      it "NEW fail, version      " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 4) (Just "abcd", 5) `shouldReturn` 0
-      it "JOIN fail, no auth     " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 1
-      it "JOIN fail, bad auth    " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "wrong", 5) `shouldReturn` 1
-      it "JOIN fail, version     " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 4) `shouldReturn` 1
-    describe "no server auth" $ do
-      it "success     " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
-      it "srv disabled" $ testBasicAuth t False (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 0
-      it "version srv " $ testBasicAuth t True (Nothing, 4) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
-      it "version fst " $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 5) `shouldReturn` 2
-      it "version snd " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 4) `shouldReturn` 2
-      it "version both" $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
-      it "version all " $ testBasicAuth t True (Nothing, 4) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
-      it "auth fst    " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
-      it "auth fst 2  " $ testBasicAuth t True (Nothing, 4) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
-      it "auth snd    " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 2
-      it "auth both   " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
-      it "auth, disabled" $ testBasicAuth t False (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
-  describe "SMP server test via agent API" $ do
-    it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
-    let srv1 = testSMPServer2 {keyHash = "1234"}
-    it "should fail with incorrect fingerprint" $ do
-      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (SMPTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
-    describe "server with password" $ do
-      let auth = Just "abcd"
-          srv = ProtoServerWithAuth testSMPServer2
-          authErr = Just (SMPTestFailure TSCreateQueue $ SMP AUTH)
-      it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing
-      it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
-      it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
-  describe "getRatchetAdHash" $
-    it "should return the same data for both peers" $
-      withSmpServer t testRatchetAdHash
 
-testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
-testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
-  let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = mkVersionRange 4 srvVersion}
-      canCreate1 = canCreateQueue allowNewQueues srv clnt1
-      canCreate2 = canCreateQueue allowNewQueues srv clnt2
-      expected
-        | canCreate1 && canCreate2 = 2
-        | canCreate1 = 1
-        | otherwise = 0
-  created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth clnt1 clnt2
-  created `shouldBe` expected
-  pure created
+testAgentClient :: IO ()
+testAgentClient = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 3
 
-canCreateQueue :: Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> Bool
-canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
-  allowNew && (isNothing srvAuth || (srvVersion == 5 && clntVersion == 5 && srvAuth == clntAuth))
+testAgentClientV1toV1 :: IO ()
+testAgentClientV1toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
 
-testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
-testMatrix2 t runTest = do
-  it "v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
-  it "v1" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfgV1 4 runTest
-  it "v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfg 4 runTest
-  it "v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgV1 4 runTest
+testAgentClientV1toV2 :: IO ()
+testAgentClientV1toV2 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
 
-testRatchetMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
-testRatchetMatrix2 t runTest = do
-  it "ratchet v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
-  it "ratchet v1" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfgRatchetV1 3 runTest
-  it "ratchets v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfg 3 runTest
-  it "ratchets v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetV1 3 runTest
+testAgentClientV2toV1 :: IO ()
+testAgentClientV2toV1 = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
 
-testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
-testServerMatrix2 t runTest = do
-  it "1 server" $ withSmpServer t $ runTest initAgentServers
-  it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
+testAgentClientContact :: IO ()
+testAgentClientContact = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 3
 
-runTestCfg2 :: AgentConfig -> AgentConfig -> AgentMsgId -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
-runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do
-  alice <- getSMPAgentClient aliceCfg initAgentServers
-  bob <- getSMPAgentClient bobCfg {database = testDB2} initAgentServers
-  runTest alice bob baseMsgId
+testAgentClientContactV1toV1 :: IO ()
+testAgentClientContactV1toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
+
+testAgentClientContactV1toV2 :: IO ()
+testAgentClientContactV1toV2 = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
+
+testAgentClientContactV2toV1 :: IO ()
+testAgentClientContactV2toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
 
 runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientTest alice bob baseId = do
-  runRight_ $ do
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
+  Right () <- runExceptT $ do
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -258,17 +170,18 @@ runAgentClientTest alice bob baseId = do
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
+  pure ()
   where
     msgId = subtract baseId
 
 runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest alice bob baseId = do
-  runRight_ $ do
-    (_, qInfo) <- createConnection alice True SCMContact Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- acceptContact alice True invId "alice's connInfo"
-    ("", _, CONF confId _ "alice's connInfo") <- get bob
+  Right () <- runExceptT $ do
+    (_, qInfo) <- createConnection alice SCMContact
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    ("", _, REQ invId "bob's connInfo") <- get alice
+    bobId <- acceptContact alice invId "alice's connInfo"
+    ("", _, CONF confId "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
     get alice ##> ("", bobId, CON)
@@ -295,6 +208,7 @@ runAgentClientContactTest alice bob baseId = do
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
+  pure ()
   where
     msgId = subtract baseId
 
@@ -309,109 +223,121 @@ noMessages c err = tryGet `shouldReturn` ()
 testAsyncInitiatingOffline :: IO ()
 testAsyncInitiatingOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob cReq "bob's connInfo"
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId _ "bob's connInfo") <- get alice'
+    ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
     get alice' ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
     exchangeGreetings alice' bobId bob aliceId
+  pure ()
 
 testAsyncJoiningOfflineBeforeActivation :: IO ()
 testAsyncJoiningOfflineBeforeActivation = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
     disconnectAgentClient bob
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
     get bob' ##> ("", aliceId, CON)
     exchangeGreetings alice bobId bob' aliceId
+  pure ()
 
 testAsyncBothOffline :: IO ()
 testAsyncBothOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob cReq "bob's connInfo"
     disconnectAgentClient bob
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId _ "bob's connInfo") <- get alice'
+    ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
     get bob' ##> ("", aliceId, CON)
     exchangeGreetings alice' bobId bob' aliceId
+  pure ()
 
 testAsyncServerOffline :: ATransport -> IO ()
 testAsyncServerOffline t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   -- create connection and shutdown the server
-  (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
-    runRight $ createConnection alice True SCMInvitation Nothing
+  Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
+    runExceptT $ createConnection alice SCMInvitation
   -- connection fails
-  Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob True cReq "bob's connInfo"
+  Left (BROKER NETWORK) <- runExceptT $ joinConnection bob cReq "bob's connInfo"
   ("", "", DOWN srv conns) <- get alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
   -- connection succeeds after server start
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
+  Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
     ("", "", UP srv1 conns1) <- get alice
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    aliceId <- joinConnection bob cReq "bob's connInfo"
+    ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
     exchangeGreetings alice bobId bob aliceId
+  pure ()
 
 testAsyncHelloTimeout :: IO ()
 testAsyncHelloTimeout = do
   -- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
   alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2, helloTimeout = 1} initAgentServers
-  runRight_ $ do
-    (_, cReq) <- createConnection alice True SCMInvitation Nothing
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
+  Right () <- runExceptT $ do
+    (_, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
+  pure ()
 
 testDuplicateMessage :: ATransport -> IO ()
 testDuplicateMessage t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
-    (aliceId, bobId) <- runRight $ makeConnection alice bob
-    runRight_ $ do
+    Right (aliceId, bobId) <- runExceptT $ do
+      (bobId, qInfo) <- createConnection alice SCMInvitation
+      aliceId <- joinConnection bob qInfo "bob's connInfo"
+      ("", _, CONF confId "bob's connInfo") <- get alice
+      allowConnection alice bobId confId "alice's connInfo"
+      get alice ##> ("", bobId, CON)
+      get bob ##> ("", aliceId, INFO "alice's connInfo")
+      get bob ##> ("", aliceId, CON)
       4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
       get alice ##> ("", bobId, SENT 4)
       get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+      pure (aliceId, bobId)
     disconnectAgentClient bob
 
     -- if the agent user did not send ACK, the message will be delivered again
-    bob1 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-    runRight_ $ do
+    bob1 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    Right () <- runExceptT $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
       ackMessage bob1 aliceId 4
@@ -423,19 +349,19 @@ testDuplicateMessage t = do
 
   get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
   get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
-  -- commenting two lines below and uncommenting further two lines would also runRight_,
+  -- commenting two lines below and uncommenting further two lines would also pass,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
+  Left (BROKER TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
 
   disconnectAgentClient alice
   disconnectAgentClient bob1
 
   alice2 <- getSMPAgentClient agentCfg initAgentServers
-  bob2 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  bob2 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
-    runRight_ $ do
+    Right () <- runExceptT $ do
       subscribeConnection bob2 aliceId
       subscribeConnection alice2 bobId
       -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
@@ -444,26 +370,17 @@ testDuplicateMessage t = do
       6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
       get alice2 ##> ("", bobId, SENT 6)
       get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
-
-makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnection alice bob = do
-  (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-  aliceId <- joinConnection bob True qInfo "bob's connInfo"
-  ("", _, CONF confId _ "bob's connInfo") <- get alice
-  allowConnection alice bobId confId "alice's connInfo"
-  get alice ##> ("", bobId, CON)
-  get bob ##> ("", aliceId, INFO "alice's connInfo")
-  get bob ##> ("", aliceId, CON)
-  pure (aliceId, bobId)
+    pure ()
 
 testInactiveClientDisconnected :: ATransport -> IO ()
 testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
-    runRight_ $ do
-      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
+    Right () <- runExceptT $ do
+      (connId, _cReq) <- createConnection alice SCMInvitation
       get alice ##> ("", "", DOWN testSMPServer [connId])
+    pure ()
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
 testActiveClientNotDisconnected t = do
@@ -471,13 +388,14 @@ testActiveClientNotDisconnected t = do
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
     ts <- getSystemTime
-    runRight_ $ do
-      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
+    Right () <- runExceptT $ do
+      (connId, _cReq) <- createConnection alice SCMInvitation
       keepSubscribing alice connId ts
+    pure ()
   where
     keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO ()
     keepSubscribing alice connId ts = do
-      ts' <- liftIO getSystemTime
+      ts' <- liftIO $ getSystemTime
       if milliseconds ts' - milliseconds ts < 2200
         then do
           -- keep sending SUB for 2.2 seconds
@@ -492,358 +410,13 @@ testActiveClientNotDisconnected t = do
           get alice ##> ("", "", DOWN testSMPServer [connId])
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
-testSuspendingAgent :: IO ()
-testSuspendingAgent = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (aId, bId) <- makeConnection a b
-    4 <- sendMessage a bId SMP.noMsgFlags "hello"
-    get a ##> ("", bId, SENT 4)
-    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
-    suspendAgent b 1000000
-    get b ##> ("", "", SUSPENDED)
-    5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
-    get a ##> ("", bId, SENT 5)
-    Nothing <- 100000 `timeout` get b
-    activateAgent b
-    get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
-
-testSuspendingAgentCompleteSending :: ATransport -> IO ()
-testSuspendingAgentCompleteSending t = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
-    (aId, bId) <- makeConnection a b
-    4 <- sendMessage a bId SMP.noMsgFlags "hello"
-    get a ##> ("", bId, SENT 4)
-    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
-    pure (aId, bId)
-
-  runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
-    5 <- sendMessage b aId SMP.noMsgFlags "hello too"
-    6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
-    liftIO $ threadDelay 100000
-    suspendAgent b 5000000
-
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    ("", "", SUSPENDED) <- get b
-
-    r <- get a
-    liftIO $ print r
-    ("", "", UP {}) <- pure r
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
-    ackMessage a bId 5
-    get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
-    ackMessage a bId 6
-
-testSuspendingAgentTimeout :: ATransport -> IO ()
-testSuspendingAgentTimeout t = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (aId, _) <- withSmpServer t . runRight $ do
-    (aId, bId) <- makeConnection a b
-    4 <- sendMessage a bId SMP.noMsgFlags "hello"
-    get a ##> ("", bId, SENT 4)
-    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
-    pure (aId, bId)
-
-  runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
-    5 <- sendMessage b aId SMP.noMsgFlags "hello too"
-    6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
-    suspendAgent b 100000
-    ("", "", SUSPENDED) <- get b
-    pure ()
-
-testBatchedSubscriptions :: ATransport -> IO ()
-testBatchedSubscriptions t = do
-  a <- getSMPAgentClient agentCfg initAgentServers2
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers2
-  conns <- runServers $ do
-    conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
-    forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
-    forM_ (take 10 conns) $ \(aId, bId) -> do
-      deleteConnection a bId
-      deleteConnection b aId
-    liftIO $ threadDelay 1000000
-    pure conns
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get b
-  ("", "", DOWN {}) <- get b
-  runServers $ do
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get b
-    ("", "", UP {}) <- get b
-    liftIO $ threadDelay 1000000
-    subscribe a $ map snd conns
-    subscribe b $ map fst conns
-    forM_ (drop 10 conns) $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
-  where
-    subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
-    subscribe c cs = do
-      r <- subscribeConnections c cs
-      liftIO $ do
-        let dc = S.fromList $ take 10 cs
-        all (== Right ()) (M.withoutKeys r dc) `shouldBe` True
-        all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
-        M.keys r `shouldMatchList` cs
-    runServers :: ExceptT AgentErrorType IO a -> IO a
-    runServers a = do
-      withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
-          runRight a `finally` killThread t2
-        killThread t1
-        pure res
-
-testAsyncCommands :: IO ()
-testAsyncCommands = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    bobId <- createConnectionAsync alice "1" True SCMInvitation
-    ("1", bobId', INV (ACR _ qInfo)) <- get alice
-    liftIO $ bobId' `shouldBe` bobId
-    aliceId <- joinConnectionAsync bob "2" True qInfo "bob's connInfo"
-    ("2", aliceId', OK) <- get bob
-    liftIO $ aliceId' `shouldBe` aliceId
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
-    allowConnectionAsync alice "3" bobId confId "alice's connInfo"
-    ("3", _, OK) <- get alice
-    get alice ##> ("", bobId, CON)
-    get bob ##> ("", aliceId, INFO "alice's connInfo")
-    get bob ##> ("", aliceId, CON)
-    -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
-    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
-    get alice ##> ("", bobId, SENT $ baseId + 1)
-    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
-    get alice ##> ("", bobId, SENT $ baseId + 2)
-    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessageAsync bob "4" aliceId $ baseId + 1
-    ("4", _, OK) <- get bob
-    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessageAsync bob "5" aliceId $ baseId + 2
-    ("5", _, OK) <- get bob
-    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
-    get bob ##> ("", aliceId, SENT $ baseId + 3)
-    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
-    get bob ##> ("", aliceId, SENT $ baseId + 4)
-    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessageAsync alice "6" bobId $ baseId + 3
-    ("6", _, OK) <- get alice
-    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessageAsync alice "7" bobId $ baseId + 4
-    ("7", _, OK) <- get alice
-    deleteConnectionAsync alice "8" bobId
-    ("8", _, OK) <- get alice
-    liftIO $ noMessages alice "nothing else should be delivered to alice"
-  where
-    baseId = 3
-    msgId = subtract baseId
-
-testAsyncCommandsRestore :: ATransport -> IO ()
-testAsyncCommandsRestore t = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bobId <- runRight $ createConnectionAsync alice "1" True SCMInvitation
-  liftIO $ noMessages alice "alice doesn't receive INV because server is down"
-  disconnectAgentClient alice
-  alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
-  withSmpServerStoreLogOn t testPort $ \_ -> do
-    runRight_ $ do
-      subscribeConnection alice' bobId
-      ("1", _, INV _) <- get alice'
-      pure ()
-
-testAcceptContactAsync :: IO ()
-testAcceptContactAsync = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (_, qInfo) <- createConnection alice True SCMContact Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- acceptContactAsync alice "1" True invId "alice's connInfo"
-    ("1", bobId', OK) <- get alice
-    liftIO $ bobId' `shouldBe` bobId
-    ("", _, CONF confId _ "alice's connInfo") <- get bob
-    allowConnection bob aliceId confId "bob's connInfo"
-    get alice ##> ("", bobId, INFO "bob's connInfo")
-    get alice ##> ("", bobId, CON)
-    get bob ##> ("", aliceId, CON)
-    -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
-    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
-    get alice ##> ("", bobId, SENT $ baseId + 1)
-    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
-    get alice ##> ("", bobId, SENT $ baseId + 2)
-    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 1
-    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 2
-    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
-    get bob ##> ("", aliceId, SENT $ baseId + 3)
-    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
-    get bob ##> ("", aliceId, SENT $ baseId + 4)
-    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
-    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
-    suspendConnection alice bobId
-    5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
-    get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
-    deleteConnection alice bobId
-    liftIO $ noMessages alice "nothing else should be delivered to alice"
-  where
-    baseId = 3
-    msgId = subtract baseId
-
-testSwitchConnection :: InitialAgentServers -> IO ()
-testSwitchConnection servers = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
-  runRight_ $ do
-    (aId, bId) <- makeConnection a b
-    exchangeGreetingsMsgId 4 a bId b aId
-    switchConnectionAsync a "" bId
-    switchComplete a bId b aId
-    exchangeGreetingsMsgId 10 a bId b aId
-
-switchComplete :: AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()
-switchComplete a bId b aId = do
-  phase a bId QDRcv SPStarted
-  phase b aId QDSnd SPStarted
-  phase a bId QDRcv SPConfirmed
-  phase b aId QDSnd SPConfirmed
-  phase b aId QDSnd SPCompleted
-  phase a bId QDRcv SPCompleted
-
-phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> ExceptT AgentErrorType IO ()
-phase c connId d p =
-  get c >>= \(_, connId', msg) -> do
-    liftIO $ connId `shouldBe` connId'
-    case msg of
-      SWITCH d' p' _ -> liftIO $ do
-        d `shouldBe` d'
-        p `shouldBe` p'
-      ERR (AGENT A_DUPLICATE) -> phase c connId d p
-      r -> do
-        liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
-        SWITCH {} <- pure r
-        pure ()
-
-testSwitchAsync :: InitialAgentServers -> IO ()
-testSwitchAsync servers = do
-  (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
-    (aId, bId) <- makeConnection a b
-    exchangeGreetingsMsgId 4 a bId b aId
-    pure (aId, bId)
-  let withA' = session withA bId
-      withB' = session withB aId
-  withA' $ \a -> do
-    switchConnectionAsync a "" bId
-    phase a bId QDRcv SPStarted
-  withB' $ \b -> phase b aId QDSnd SPStarted
-  withA' $ \a -> phase a bId QDRcv SPConfirmed
-  withB' $ \b -> do
-    phase b aId QDSnd SPConfirmed
-    phase b aId QDSnd SPCompleted
-  withA' $ \a -> phase a bId QDRcv SPCompleted
-  withA $ \a -> withB $ \b -> runRight_ $ do
-    subscribeConnection a bId
-    subscribeConnection b aId
-    exchangeGreetingsMsgId 10 a bId b aId
-  where
-    withAgent :: AgentConfig -> (AgentClient -> IO a) -> IO a
-    withAgent cfg' = bracket (getSMPAgentClient cfg' servers) disconnectAgentClient
-    session :: (forall a. (AgentClient -> IO a) -> IO a) -> ConnId -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
-    session withC connId a =
-      withC $ \c -> runRight_ $ do
-        subscribeConnection c connId
-        r <- a c
-        liftIO $ threadDelay 500000
-        pure r
-    withA = withAgent agentCfg
-    withB = withAgent agentCfg {database = testDB2, initialClientId = 1}
-
-testSwitchDelete :: InitialAgentServers -> IO ()
-testSwitchDelete servers = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
-  runRight_ $ do
-    (aId, bId) <- makeConnection a b
-    exchangeGreetingsMsgId 4 a bId b aId
-    disconnectAgentClient b
-    switchConnectionAsync a "" bId
-    phase a bId QDRcv SPStarted
-    deleteConnectionAsync a "1" bId
-    ("1", bId', OK) <- get a
-    liftIO $ bId `shouldBe` bId'
-
-testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
-testCreateQueueAuth clnt1 clnt2 = do
-  a <- getClient clnt1
-  b <- getClient clnt2
-  runRight $ do
-    tryError (createConnection a True SCMInvitation Nothing) >>= \case
-      Left (SMP AUTH) -> pure 0
-      Left e -> throwError e
-      Right (bId, qInfo) ->
-        tryError (joinConnection b True qInfo "bob's connInfo") >>= \case
-          Left (SMP AUTH) -> pure 1
-          Left e -> throwError e
-          Right aId -> do
-            ("", _, CONF confId _ "bob's connInfo") <- get a
-            allowConnection a bId confId "alice's connInfo"
-            get a ##> ("", bId, CON)
-            get b ##> ("", aId, INFO "alice's connInfo")
-            get b ##> ("", aId, CON)
-            exchangeGreetings a bId b aId
-            pure 2
-  where
-    getClient (clntAuth, clntVersion) =
-      let servers = initAgentServers {smp = [ProtoServerWithAuth testSMPServer clntAuth]}
-          smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
-       in getSMPAgentClient agentCfg {smpCfg} servers
-
-testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe SMPTestFailure)
-testSMPServerConnectionTest t newQueueBasicAuth srv =
-  withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
-    a <- getSMPAgentClient agentCfg initAgentServers -- initially passed server is not running
-    runRight $ testSMPServerConnection a srv
-
-testRatchetAdHash :: IO ()
-testRatchetAdHash = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    (aId, bId) <- makeConnection a b
-    ad1 <- getConnectionRatchetAdHash a bId
-    ad2 <- getConnectionRatchetAdHash b aId
-    liftIO $ ad1 `shouldBe` ad2
-
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetings = exchangeGreetingsMsgId 4
-
-exchangeGreetingsMsgId :: Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
-  msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
-  liftIO $ msgId1 `shouldBe` msgId
-  get alice ##> ("", bobId, SENT msgId)
+exchangeGreetings alice bobId bob aliceId = do
+  4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+  get alice ##> ("", bobId, SENT 4)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId msgId
-  msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
-  let msgId' = msgId + 1
-  liftIO $ msgId2 `shouldBe` msgId'
-  get bob ##> ("", aliceId, SENT msgId')
+  ackMessage bob aliceId 4
+  5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
+  get bob ##> ("", aliceId, SENT 5)
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId msgId'
+  ackMessage alice bobId 5

tests/AgentTests/NotificationTests.hs

@@ -8,42 +8,36 @@
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
-import Control.Concurrent (killThread, threadDelay)
+
+import AgentTests.FunctionalAPITests (get, (##>), (=##>), pattern Msg)
+import Control.Concurrent (threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
-import Data.Bifunctor (bimap, first)
+import Data.Bifunctor (bimap)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
-import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
+import SMPClient (withSmpServer)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers, databaseFile)
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Types (NtfToken (..))
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
+import Simplex.Messaging.Protocol (ErrorType (AUTH))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Util (tryE)
-import System.Directory (doesFileExist, removeFile)
+import System.Directory (removeFile)
 import Test.Hspec
 import UnliftIO
 
-removeFileIfExists :: FilePath -> IO ()
-removeFileIfExists filePath = do
-  fileExists <- doesFileExist filePath
-  when fileExists $ removeFile filePath
-
 notificationTests :: ATransport -> Spec
 notificationTests t =
-  after_ (removeFile (databaseFile testDB) >> removeFileIfExists (databaseFile testDB2)) $ do
+  after_ (removeFile testDB) $ do
     describe "Managing notification tokens" $ do
       it "should register and verify notification token" $
         withAPNSMockServer $ \apns ->
@@ -66,45 +60,26 @@ notificationTests t =
         withSmpServer t $
           withAPNSMockServer $ \apns ->
             withNtfServer t $ testNotificationSubscriptionNewConnection apns
-      it "should change notifications mode" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeNotificationsMode apns
-      it "should change token" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeToken apns
-    describe "Notifications server store log" $
-      it "should save and restore tokens and subscriptions" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            testNotificationsStoreLog t apns
-    describe "Notifications after SMP server restart" $
-      it "should resume subscriptions after SMP server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationsSMPRestart t apns
-    describe "should switch notifications to the new queue" $
-      testServerMatrix2 t $ \servers ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testSwitchNotifications servers apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
+  Right () <- runExceptT $ do
+    let tkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken a tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken a tkn nonce verification
+    verifyNtfToken a tkn verification nonce
+    enableNtfCron a tkn 30
     NTActive <- checkNtfToken a tkn
     deleteNtfToken a tkn
     -- agent deleted this token
     Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
     pure ()
+  pure ()
 
 (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
 v .-> key = do
@@ -119,42 +94,44 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
+  Right () <- runExceptT $ do
+    let tkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken a tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     _ <- ntfData' .-> "verification"
     _ <- C.cbNonce <$> ntfData' .-> "nonce"
     liftIO $ sendApnsResponse' APNSRespOk
     -- can still use the first verification code, it is the same after decryption
-    verifyNtfToken a tkn nonce verification
+    verifyNtfToken a tkn verification nonce
+    enableNtfCron a tkn 30
     NTActive <- checkNtfToken a tkn
     pure ()
+  pure ()
 
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
-  a' <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
+  a' <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    let tkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken a tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken a tkn nonce verification
+    verifyNtfToken a tkn verification nonce
 
-    NTRegistered <- registerNtfToken a' tkn NMPeriodic
+    NTRegistered <- registerNtfToken a' tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     verification' <- ntfData' .-> "verification"
@@ -165,21 +142,25 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     NTActive <- checkNtfToken a tkn
     -- and the second is not yet verified
     liftIO $ threadDelay 50000
-    NTConfirmed <- checkNtfToken a' tkn
+    r <- checkNtfToken a' tkn
+    liftIO . print $ "checkNtfToken a' tkn: " <> show r
+    unless (r == NTConfirmed) $ error "bad status"
     -- now the second token registration is verified
-    verifyNtfToken a' tkn nonce' verification'
+    verifyNtfToken a' tkn verification' nonce'
     -- the first registration is removed
     Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
     -- and the second is active
     NTActive <- checkNtfToken a' tkn
+    enableNtfCron a' tkn 30
     pure ()
+  pure ()
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  let tkn = DeviceToken PPApnsTest "abcd"
-  ntfData <- withNtfServer t . runRight $ do
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
+  let tkn = DeviceToken PPApns "abcd"
+  Right ntfData <- withNtfServer t . runExceptT $ do
+    NTRegistered <- registerNtfToken a tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     liftIO $ sendApnsResponse APNSRespOk
@@ -190,71 +171,55 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   a' <- getSMPAgentClient agentCfg initAgentServers
   -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
   -- so that repeat verification happens without restarting the clients, when notification arrives
-  withNtfServer t . runRight_ $ do
+  Right () <- withNtfServer t . runExceptT $ do
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
+    Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn verification nonce
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     verification' <- ntfData' .-> "verification"
     nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
     liftIO $ sendApnsResponse' APNSRespOk
-    verifyNtfToken a' tkn nonce' verification'
+    verifyNtfToken a' tkn verification' nonce'
     NTActive <- checkNtfToken a' tkn
-    pure ()
+    enableNtfCron a' tkn 30
+  pure ()
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (bobId, aliceId, nonce, message) <- runRight $ do
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token
-    let tkn = DeviceToken PPApnsTest "abcd"
-    NTRegistered <- registerNtfToken alice tkn NMInstant
+    let tkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken alice tkn
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
-    vNonce <- C.cbNonce <$> ntfData .-> "nonce"
+    nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken alice tkn vNonce verification
+    verifyNtfToken alice tkn verification nonce
     NTActive <- checkNtfToken alice tkn
     -- send message
     liftIO $ threadDelay 50000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    -- notification
-    (nonce, message) <- messageNotification apnsQ
-    pure (bobId, aliceId, nonce, message)
-
-  -- alice client already has subscription for the connection
-  Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
-
-  -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  aliceNtf <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
-    (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
-    pure ()
-  disconnectAgentClient aliceNtf
-
-  runRight_ $ do
+    messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
-    -- delete notification subscription
-    toggleConnectionNtfs alice bobId False
-    liftIO $ threadDelay 250000
-    -- send message
-    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
-    get bob ##> ("", aliceId, SENT $ baseId + 2)
-    -- no notifications should follow
-    noNotification apnsQ
+    -- no unexpected notifications should follow
+    500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+      Nothing -> pure ()
+      _ -> error "unexpected notification"
+  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -262,263 +227,70 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
     -- alice registers notification token
-    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
+    let aliceTkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken alice aliceTkn
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
+      atomically $ readTBQueue apnsQ
+    verification <- ntfData .-> "verification"
+    nonce <- C.cbNonce <$> ntfData .-> "nonce"
+    liftIO $ sendApnsResponse APNSRespOk
+    verifyNtfToken alice aliceTkn verification nonce
+    NTActive <- checkNtfToken alice aliceTkn
     -- bob registers notification token
-    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ
+    let bobTkn = DeviceToken PPApns "bcde"
+    NTRegistered <- registerNtfToken bob bobTkn
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
+      atomically $ readTBQueue apnsQ
+    verification' <- ntfData' .-> "verification"
+    nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
+    liftIO $ sendApnsResponse' APNSRespOk
+    verifyNtfToken bob bobTkn verification' nonce'
+    NTActive <- checkNtfToken bob bobTkn
     -- establish connection
     liftIO $ threadDelay 50000
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    liftIO $ threadDelay 1000000
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    liftIO $ threadDelay 750000
-    void $ messageNotification apnsQ
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    liftIO $ threadDelay 500000
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    messageNotification apnsQ
+    ("", _, CONF confId "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    void $ messageNotification apnsQ
+    messageNotification apnsQ
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    void $ messageNotification apnsQ
+    messageNotification apnsQ
     get alice ##> ("", bobId, CON)
-    void $ messageNotification apnsQ
+    messageNotification apnsQ
     get bob ##> ("", aliceId, CON)
     -- bob sends message
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
+    messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
-    void $ messageNotification apnsQ
+    messageNotification apnsQ
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
     ackMessage bob aliceId $ baseId + 2
     -- no unexpected notifications should follow
-    noNotification apnsQ
+    500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+      Nothing -> pure ()
+      _ -> error "unexpected notification"
+  pure ()
   where
     baseId = 3
     msgId = subtract baseId
 
-registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
-registerTestToken a token mode apnsQ = do
-  let tkn = DeviceToken PPApnsTest token
-  NTRegistered <- registerNtfToken a tkn mode
-  APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-    atomically $ readTBQueue apnsQ
-  verification' <- ntfData' .-> "verification"
-  nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
-  liftIO $ sendApnsResponse' APNSRespOk
-  verifyNtfToken a tkn nonce' verification'
-  NTActive <- checkNtfToken a tkn
-  pure tkn
-
-testChangeNotificationsMode :: APNSMockServer -> IO ()
-testChangeNotificationsMode APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  runRight_ $ do
-    -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
-    allowConnection alice bobId confId "alice's connInfo"
-    get bob ##> ("", aliceId, INFO "alice's connInfo")
-    get alice ##> ("", bobId, CON)
-    get bob ##> ("", aliceId, CON)
-    -- register notification token, set mode to NMInstant
-    tkn <- registerTestToken alice "abcd" NMInstant apnsQ
-    -- send message, receive notification
-    liftIO $ threadDelay 500000
-    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
-    get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
-    -- set mode to NMPeriodic
-    NTActive <- registerNtfToken alice tkn NMPeriodic
-    -- send message, no notification
-    liftIO $ threadDelay 750000
-    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
-    get bob ##> ("", aliceId, SENT $ baseId + 2)
-    noNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 2
-    -- set mode to NMInstant
-    NTActive <- registerNtfToken alice tkn NMInstant
-    -- send message, receive notification
-    liftIO $ threadDelay 500000
-    3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
-    get bob ##> ("", aliceId, SENT $ baseId + 3)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
-    -- turn off notifications
-    deleteNtfToken alice tkn
-    -- send message, no notification
-    liftIO $ threadDelay 500000
-    4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there"
-    get bob ##> ("", aliceId, SENT $ baseId + 4)
-    noNotification apnsQ
-    get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
-    -- turn on notifications, set mode to NMInstant
-    void $ registerTestToken alice "abcd" NMInstant apnsQ
-    -- send message, receive notification
-    liftIO $ threadDelay 500000
-    5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
-    get bob ##> ("", aliceId, SENT $ baseId + 5)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 5
-    -- no notifications should follow
-    noNotification apnsQ
-  where
-    baseId = 3
-    msgId = subtract baseId
-
-testChangeToken :: APNSMockServer -> IO ()
-testChangeToken APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (aliceId, bobId) <- runRight $ do
-    -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
-    ("", _, CONF confId _ "bob's connInfo") <- get alice
-    allowConnection alice bobId confId "alice's connInfo"
-    get bob ##> ("", aliceId, INFO "alice's connInfo")
-    get alice ##> ("", bobId, CON)
-    get bob ##> ("", aliceId, CON)
-    -- register notification token, set mode to NMInstant
-    void $ registerTestToken alice "abcd" NMInstant apnsQ
-    -- send message, receive notification
-    liftIO $ threadDelay 500000
-    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
-    get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
-    pure (aliceId, bobId)
-  disconnectAgentClient alice
-
-  alice1 <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
-    subscribeConnection alice1 bobId
-    -- change notification token
-    void $ registerTestToken alice1 "bcde" NMInstant apnsQ
-    -- send message, receive notification
-    liftIO $ threadDelay 500000
-    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
-    get bob ##> ("", aliceId, SENT $ baseId + 2)
-    void $ messageNotification apnsQ
-    get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
-    ackMessage alice1 bobId $ baseId + 2
-    -- no notifications should follow
-    noNotification apnsQ
-  where
-    baseId = 3
-    msgId = subtract baseId
-
-testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
-testNotificationsStoreLog t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
-    (aliceId, bobId) <- makeConnection alice bob
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 250000
-    4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
-    get bob ##> ("", aliceId, SENT 4)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId 4
-    liftIO $ killThread threadId
-    pure (aliceId, bobId)
-
-  liftIO $ threadDelay 250000
-
-  withNtfServerStoreLog t $ \threadId -> runRight_ $ do
-    liftIO $ threadDelay 250000
-    5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
-    get bob ##> ("", aliceId, SENT 5)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-    liftIO $ killThread threadId
-
-testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
-testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
-    (aliceId, bobId) <- makeConnection alice bob
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 250000
-    4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
-    get bob ##> ("", aliceId, SENT 4)
-    void $ messageNotification apnsQ
-    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId 4
-    liftIO $ killThread threadId
-    pure (aliceId, bobId)
-
-  runRight_ $ do
-    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
-
-  withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do
-    get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
-    liftIO $ threadDelay 1000000
-    5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
-    get bob ##> ("", aliceId, SENT 5)
-    _ <- messageNotificationData alice apnsQ
-    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-    liftIO $ killThread threadId
-
-testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
-testSwitchNotifications servers APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
-  runRight_ $ do
-    (aId, bId) <- makeConnection a b
-    exchangeGreetingsMsgId 4 a bId b aId
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 250000
-    let testMessage msg = do
-          msgId <- sendMessage b aId (SMP.MsgFlags True) msg
-          get b ##> ("", aId, SENT msgId)
-          void $ messageNotification apnsQ
-          get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
-          ackMessage a bId msgId
-    testMessage "hello"
-    switchConnectionAsync a "" bId
-    switchComplete a bId b aId
-    liftIO $ threadDelay 500000
-    testMessage "hello again"
-
-messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
+messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
 messageNotification apnsQ = do
-  750000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
     Nothing -> error "no notification"
     Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
-      nonce <- C.cbNonce <$> ntfData .-> "nonce"
-      message <- ntfData .-> "message"
+      _ <- ntfData .-> "checkMessage"
+      _ <- C.cbNonce <$> ntfData .-> "nonce"
       liftIO $ sendApnsResponse APNSRespOk
-      pure (nonce, message)
     _ -> error "bad notification"
-
-messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
-messageNotificationData c apnsQ = do
-  (nonce, message) <- messageNotification apnsQ
-  NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
-  Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
-  pure pnMsgData
-
-noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
-noNotification apnsQ = do
-  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
-    Nothing -> pure ()
-    _ -> error "unexpected notification"

tests/AgentTests/SQLiteTests.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -12,6 +11,7 @@ module AgentTests.SQLiteTests (storeTests) where
 import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Monad (replicateM_)
+import Control.Monad.Except (ExceptT, runExceptT)
 import Crypto.Random (drgNew)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.Text as T
@@ -44,7 +44,7 @@ withStore2 = before connect2 . after (removeStore . fst)
     connect2 :: IO (SQLiteStore, SQLiteStore)
     connect2 = do
       s1 <- createStore
-      s2 <- connectSQLiteStore (dbFilePath s1) ""
+      s2 <- connectSQLiteStore (dbFilePath s1) Nothing
       pure (s1, s2)
 
 createStore :: IO SQLiteStore
@@ -52,26 +52,32 @@ createStore = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  createSQLiteStore (testDB <> show r) "" Migrations.app True
+  createSQLiteStore (testDB <> show r) Nothing Migrations.app True
 
 removeStore :: SQLiteStore -> IO ()
-removeStore db = do
-  close db
-  removeFile $ dbFilePath db
+removeStore store = do
+  close store
+  removeFile $ dbFilePath store
   where
     close :: SQLiteStore -> IO ()
     close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
 
+returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation
+action `returnsResult` r = runExceptT action `shouldReturn` Right r
+
+throwsError :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> e -> Expectation
+action `throwsError` e = runExceptT action `shouldReturn` Left e
+
 -- TODO add null port tests
 storeTests :: Spec
 storeTests = do
   withStore2 $ do
     describe "stress test" testConcurrentWrites
   withStore $ do
-    describe "db setup" $ do
+    describe "store setup" $ do
       testCompiledThreadsafe
       testForeignKeysEnabled
-    describe "db methods" $ do
+    describe "store methods" $ do
       describe "Queue and Connection management" $ do
         describe "createRcvConn" $ do
           testCreateRcvConn
@@ -106,29 +112,28 @@ testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
 testConcurrentWrites =
   it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
     g <- newTVarIO =<< drgNew
-    _ <- withTransaction s1 $ \db ->
-      createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- runExceptT $ createRcvConn s1 g cData1 rcvQueue1 SCMInvitation
     let ConnData {connId} = cData1
     concurrently_ (runTest s1 connId) (runTest s2 connId)
   where
-    runTest :: SQLiteStore -> ConnId -> IO ()
-    runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
-      (internalId, internalRcvId, _, _) <- updateRcvIds db connId
+    runTest :: SQLiteStore -> ConnId -> IO (Either StoreError ())
+    runTest store connId = runExceptT . replicateM_ 100 $ do
+      (internalId, internalRcvId, _, _) <- updateRcvIds store connId
       let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
-      createRcvMsg db connId rcvQueue1 rcvMsgData
+      createRcvMsg store connId rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
 testCompiledThreadsafe =
-  it "compiled sqlite library should be threadsafe" . withStoreTransaction $ \db -> do
+  it "compiled sqlite library should be threadsafe" . withStoreConnection $ \db -> do
     compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[T.Text]]
     compileOptions `shouldNotContain` [["THREADSAFE=0"]]
 
-withStoreTransaction :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
-withStoreTransaction = flip withTransaction
+withStoreConnection :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
+withStoreConnection = flip withConnection
 
 testForeignKeysEnabled :: SpecWith SQLiteStore
 testForeignKeysEnabled =
-  it "foreign keys should be enabled" . withStoreTransaction $ \db -> do
+  it "foreign keys should be enabled" . withStoreConnection $ \db -> do
     let inconsistentQuery =
           [sql|
             INSERT INTO snd_queues
@@ -140,7 +145,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
+cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -154,255 +159,233 @@ testDhSecret = "01234567890123456789012345678901"
 rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
-    { connId = "conn1",
-      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       rcvId = "1234",
       rcvPrivateKey = testPrivateSignKey,
       rcvDhSecret = testDhSecret,
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
-      sndId = "2345",
+      sndId = Just "2345",
       status = New,
-      dbQueueId = 1,
-      primary = True,
-      dbReplaceQueueId = Nothing,
-      smpClientVersion = 1,
-      clientNtfCreds = Nothing
+      ntfPublicKey = Nothing,
+      ntfPrivateKey = Nothing,
+      notifierId = Nothing
     }
 
 sndQueue1 :: SndQueue
 sndQueue1 =
   SndQueue
-    { connId = "conn1",
-      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       sndId = "3456",
       sndPublicKey = Nothing,
       sndPrivateKey = testPrivateSignKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
-      status = New,
-      dbQueueId = 1,
-      primary = True,
-      dbReplaceQueueId = Nothing,
-      smpClientVersion = 1
+      status = New
     }
 
 testCreateRcvConn :: SpecWith SQLiteStore
 testCreateRcvConn =
-  it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
+  it "should create RcvConnection and add SndQueue" $ \store -> do
     g <- newTVarIO =<< drgNew
-    createRcvConn db g cData1 rcvQueue1 SCMInvitation
-      `shouldReturn` Right "conn1"
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
-    upgradeRcvConnToDuplex db "conn1" sndQueue1
-      `shouldReturn` Right 1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+    createRcvConn store g cData1 rcvQueue1 SCMInvitation
+      `returnsResult` "conn1"
+    getConn store "conn1"
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
+    upgradeRcvConnToDuplex store "conn1" sndQueue1
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
-  it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
+  it "should create RcvConnection and add SndQueue with random ID" $ \store -> do
     g <- newTVarIO =<< drgNew
-    Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
-    let rq' = (rcvQueue1 :: RcvQueue) {connId}
-        sq' = (sndQueue1 :: SndQueue) {connId}
-    getConn db connId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq'))
-    upgradeRcvConnToDuplex db connId sndQueue1
-      `shouldReturn` Right 1
-    getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
+    Right connId <- runExceptT $ createRcvConn store g cData1 {connId = ""} rcvQueue1 SCMInvitation
+    getConn store connId
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1)
+    upgradeRcvConnToDuplex store connId sndQueue1
+      `returnsResult` ()
+    getConn store connId
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
 
 testCreateRcvConnDuplicate :: SpecWith SQLiteStore
 testCreateRcvConnDuplicate =
-  it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do
+  it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    createRcvConn db g cData1 rcvQueue1 SCMInvitation
-      `shouldReturn` Left SEConnDuplicate
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    createRcvConn store g cData1 rcvQueue1 SCMInvitation
+      `throwsError` SEConnDuplicate
 
 testCreateSndConn :: SpecWith SQLiteStore
 testCreateSndConn =
-  it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do
+  it "should create SndConnection and add RcvQueue" $ \store -> do
     g <- newTVarIO =<< drgNew
-    createSndConn db g cData1 sndQueue1
-      `shouldReturn` Right "conn1"
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
-    upgradeSndConnToDuplex db "conn1" rcvQueue1
-      `shouldReturn` Right 1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+    createSndConn store g cData1 sndQueue1
+      `returnsResult` "conn1"
+    getConn store "conn1"
+      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
+    upgradeSndConnToDuplex store "conn1" rcvQueue1
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
-  it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
+  it "should create SndConnection and add RcvQueue with random ID" $ \store -> do
     g <- newTVarIO =<< drgNew
-    Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
-    let rq' = (rcvQueue1 :: RcvQueue) {connId}
-        sq' = (sndQueue1 :: SndQueue) {connId}
-    getConn db connId
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq'))
-    upgradeSndConnToDuplex db connId rcvQueue1
-      `shouldReturn` Right 1
-    getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
+    Right connId <- runExceptT $ createSndConn store g cData1 {connId = ""} sndQueue1
+    getConn store connId
+      `returnsResult` SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1)
+    upgradeSndConnToDuplex store connId rcvQueue1
+      `returnsResult` ()
+    getConn store connId
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
 
 testCreateSndConnDuplicate :: SpecWith SQLiteStore
 testCreateSndConnDuplicate =
-  it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do
+  it "should throw error on attempt to create duplicate SndConnection" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
-    createSndConn db g cData1 sndQueue1
-      `shouldReturn` Left SEConnDuplicate
+    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
+    createSndConn store g cData1 sndQueue1
+      `throwsError` SEConnDuplicate
 
 testGetRcvConn :: SpecWith SQLiteStore
 testGetRcvConn =
-  it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do
+  it "should get connection using rcv queue id and server" $ \store -> do
     let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash
     let recipientId = "1234"
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    getRcvConn db smpServer recipientId
-      `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    getRcvConn store smpServer recipientId
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
-  it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
+  it "should create RcvConnection and delete it" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    getConn store "conn1"
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
+    deleteConn store "conn1"
+      `returnsResult` ()
     -- TODO check queues are deleted as well
-    getConn db "conn1"
-      `shouldReturn` Left SEConnNotFound
+    getConn store "conn1"
+      `throwsError` SEConnNotFound
 
 testDeleteSndConn :: SpecWith SQLiteStore
 testDeleteSndConn =
-  it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do
+  it "should create SndConnection and delete it" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
+    getConn store "conn1"
+      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
+    deleteConn store "conn1"
+      `returnsResult` ()
     -- TODO check queues are deleted as well
-    getConn db "conn1"
-      `shouldReturn` Left SEConnNotFound
+    getConn store "conn1"
+      `throwsError` SEConnNotFound
 
 testDeleteDuplexConn :: SpecWith SQLiteStore
 testDeleteDuplexConn =
-  it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do
+  it "should create DuplexConnection and delete it" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
+    deleteConn store "conn1"
+      `returnsResult` ()
     -- TODO check queues are deleted as well
-    getConn db "conn1"
-      `shouldReturn` Left SEConnNotFound
+    getConn store "conn1"
+      `throwsError` SEConnNotFound
 
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
 testUpgradeRcvConnToDuplex =
-  it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do
+  it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
+    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
-            { connId = "conn1",
-              server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = "2345",
               sndPublicKey = Nothing,
               sndPrivateKey = testPrivateSignKey,
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
-              status = New,
-              dbQueueId = 1,
-              primary = True,
-              dbReplaceQueueId = Nothing,
-              smpClientVersion = 1
+              status = New
             }
-    upgradeRcvConnToDuplex db "conn1" anotherSndQueue
-      `shouldReturn` Left (SEBadConnType CSnd)
-    _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
-    upgradeRcvConnToDuplex db "conn1" anotherSndQueue
-      `shouldReturn` Left (SEBadConnType CDuplex)
+    upgradeRcvConnToDuplex store "conn1" anotherSndQueue
+      `throwsError` SEBadConnType CSnd
+    _ <- runExceptT $ upgradeSndConnToDuplex store "conn1" rcvQueue1
+    upgradeRcvConnToDuplex store "conn1" anotherSndQueue
+      `throwsError` SEBadConnType CDuplex
 
 testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
 testUpgradeSndConnToDuplex =
-  it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do
+  it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
-            { connId = "conn1",
-              server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               rcvId = "3456",
               rcvPrivateKey = testPrivateSignKey,
               rcvDhSecret = testDhSecret,
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
-              sndId = "4567",
+              sndId = Just "4567",
               status = New,
-              dbQueueId = 1,
-              primary = True,
-              dbReplaceQueueId = Nothing,
-              smpClientVersion = 1,
-              clientNtfCreds = Nothing
+              ntfPublicKey = Nothing,
+              ntfPrivateKey = Nothing,
+              notifierId = Nothing
             }
-    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
-      `shouldReturn` Left (SEBadConnType CRcv)
-    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
-      `shouldReturn` Left (SEBadConnType CDuplex)
+    upgradeSndConnToDuplex store "conn1" anotherRcvQueue
+      `throwsError` SEBadConnType CRcv
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
+    upgradeSndConnToDuplex store "conn1" anotherRcvQueue
+      `throwsError` SEBadConnType CDuplex
 
 testSetRcvQueueStatus :: SpecWith SQLiteStore
 testSetRcvQueueStatus =
-  it "should update status of RcvQueue" . withStoreTransaction $ \db -> do
+  it "should update status of RcvQueue" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
-    setRcvQueueStatus db rcvQueue1 Confirmed
-      `shouldReturn` ()
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed}))
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    getConn store "conn1"
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
+    setRcvQueueStatus store rcvQueue1 Confirmed
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed})
 
 testSetSndQueueStatus :: SpecWith SQLiteStore
 testSetSndQueueStatus =
-  it "should update status of SndQueue" . withStoreTransaction $ \db -> do
+  it "should update status of SndQueue" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
-    setSndQueueStatus db sndQueue1 Confirmed
-      `shouldReturn` ()
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed}))
+    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
+    getConn store "conn1"
+      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
+    setSndQueueStatus store sndQueue1 Confirmed
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed})
 
 testSetQueueStatusDuplex :: SpecWith SQLiteStore
 testSetQueueStatusDuplex =
-  it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do
+  it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do
     g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
-    setRcvQueueStatus db rcvQueue1 Secured
-      `shouldReturn` ()
-    let rq' = (rcvQueue1 :: RcvQueue) {status = Secured}
-        sq' = (sndQueue1 :: SndQueue) {status = Confirmed}
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sndQueue1]))
-    setSndQueueStatus db sndQueue1 Confirmed
-      `shouldReturn` ()
-    getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq']))
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
+    setRcvQueueStatus store rcvQueue1 Secured
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1)
+    setSndQueueStatus store sndQueue1 Confirmed
+      `returnsResult` ()
+    getConn store "conn1"
+      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed})
 
 hw :: ByteString
 hw = encodeUtf8 "Hello world!"
@@ -428,24 +411,22 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
       externalPrevSndHash = "hash_from_sender"
     }
 
-testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvQueue -> RcvMsgData -> Expectation
-testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rq rcvMsgData@RcvMsgData {..} = do
+testCreateRcvMsg_ :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
+testCreateRcvMsg_ st expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
   let MsgMeta {recipient = (internalId, _)} = msgMeta
-  updateRcvIds db connId
-    `shouldReturn` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
-  createRcvMsg db connId rq rcvMsgData
-    `shouldReturn` ()
+  updateRcvIds st connId
+    `returnsResult` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
+  createRcvMsg st connId rcvMsgData
+    `returnsResult` ()
 
 testCreateRcvMsg :: SpecWith SQLiteStore
 testCreateRcvMsg =
   it "should reserve internal ids and create a RcvMsg" $ \st -> do
     g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    _ <- withTransaction st $ \db -> do
-      createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    withTransaction st $ \db -> do
-      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
-      testCreateRcvMsg_ db 1 "hash_dummy" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
+    _ <- runExceptT $ createRcvConn st g cData1 rcvQueue1 SCMInvitation
+    testCreateRcvMsg_ st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
+    testCreateRcvMsg_ st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
 
 mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
 mkSndMsgData internalId internalSndId internalHash =
@@ -460,36 +441,32 @@ mkSndMsgData internalId internalSndId internalHash =
       prevMsgHash = internalHash
     }
 
-testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
-testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do
-  updateSndIds db connId
-    `shouldReturn` (internalId, internalSndId, expectedPrevHash)
-  createSndMsg db connId sndMsgData
-    `shouldReturn` ()
+testCreateSndMsg_ :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
+testCreateSndMsg_ store expectedPrevHash connId sndMsgData@SndMsgData {..} = do
+  updateSndIds store connId
+    `returnsResult` (internalId, internalSndId, expectedPrevHash)
+  createSndMsg store connId sndMsgData
+    `returnsResult` ()
 
 testCreateSndMsg :: SpecWith SQLiteStore
 testCreateSndMsg =
-  it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do
+  it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \store -> do
     g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    _ <- withTransaction st $ \db -> do
-      createSndConn db g cData1 sndQueue1
-    withTransaction st $ \db -> do
-      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
-      testCreateSndMsg_ db "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
+    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
+    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
+    testCreateSndMsg_ store "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
 
 testCreateRcvAndSndMsgs :: SpecWith SQLiteStore
 testCreateRcvAndSndMsgs =
-  it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do
+  it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do
+    g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    _ <- withTransaction st $ \db -> do
-      g <- newTVarIO =<< drgNew
-      createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    withTransaction st $ \db -> do
-      _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
-      testCreateRcvMsg_ db 1 "rcv_hash_1" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
-      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
-      testCreateRcvMsg_ db 2 "rcv_hash_2" connId rcvQueue1 $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
-      testCreateSndMsg_ db "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
-      testCreateSndMsg_ db "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
+    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
+    testCreateRcvMsg_ store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
+    testCreateRcvMsg_ store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
+    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
+    testCreateRcvMsg_ store 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
+    testCreateSndMsg_ store "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
+    testCreateSndMsg_ store "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"

tests/AgentTests/SchemaDump.hs

@@ -20,7 +20,7 @@ schemaDumpTest =
 
 testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
-  void $ createSQLiteStore testDB "" Migrations.app False
+  void $ createSQLiteStore testDB Nothing Migrations.app False
   void $ readCreateProcess (shell $ "touch " <> schema) ""
   savedSchema <- readFile schema
   savedSchema `seq` pure ()

tests/CLITests.hs

@@ -1,80 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module CLITests where
-
-import Data.Ini (lookupValue, readIniFile)
-import Data.List (isPrefixOf)
-import Simplex.Messaging.Notifications.Server.Main
-import Simplex.Messaging.Server.Main
-import Simplex.Messaging.Transport (simplexMQVersion)
-import Simplex.Messaging.Util (catchAll_)
-import System.Directory (doesFileExist)
-import System.Environment (withArgs)
-import System.IO.Silently (capture_)
-import System.Timeout (timeout)
-import Test.Hspec
-import Test.Main (withStdin)
-
-cfgPath :: FilePath
-cfgPath = "tests/tmp/cli/etc/opt/simplex"
-
-logPath :: FilePath
-logPath = "tests/tmp/cli/etc/var/simplex"
-
-ntfCfgPath :: FilePath
-ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
-
-ntfLogPath :: FilePath
-ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
-
-cliTests :: Spec
-cliTests = do
-  describe "SMP server CLI" $ do
-    describe "initialize, start and delete the server" $ do
-      it "no store log, random password (default)" $ smpServerTest False True
-      it "with store log, random password (default)" $ smpServerTest True True
-      it "no store log, no password" $ smpServerTest False False
-      it "with store log, no password" $ smpServerTest True False
-  describe "Ntf server CLI" $ do
-    it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
-    it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
-
-smpServerTest :: Bool -> Bool -> IO ()
-smpServerTest storeLog basicAuth = do
-  capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
-    >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
-  Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
-  lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
-  lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
-  lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223"
-  lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
-  lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
-  lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
-  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
-  r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SMP server v" <> simplexMQVersion]
-  r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
-  r `shouldContain` ["Listening on port 5223 (TLS)..."]
-  r `shouldContain` ["not expiring inactive clients"]
-  r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
-  capture_ (withStdin "Y" . withArgs ["delete"] $ smpServerCLI cfgPath logPath)
-    >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
-  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
-
-ntfServerTest :: Bool -> IO ()
-ntfServerTest storeLog = do
-  capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
-    >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
-  Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini"
-  lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
-  lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
-  lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
-  lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
-  doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
-  r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SMP notifications server v" <> ntfServerVersion]
-  r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
-  r `shouldContain` ["Listening on port 443 (TLS)..."]
-  capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
-    >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
-  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False

tests/CoreTests/CryptoTests.hs

@@ -1,72 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module CoreTests.CryptoTests (cryptoTests) where
-
-import qualified Data.ByteString.Char8 as B
-import Data.Either (isRight)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import qualified Simplex.Messaging.Crypto as C
-import Test.Hspec
-import Test.Hspec.QuickCheck (modifyMaxSuccess)
-import Test.QuickCheck
-
-cryptoTests :: Spec
-cryptoTests = do
-  modifyMaxSuccess (const 10000) . describe "padding / unpadding" $ do
-    it "should pad / unpad string" . property $ \(s, paddedLen) ->
-      let b = encodeUtf8 $ T.pack s
-          len = B.length b
-          padded = C.pad b paddedLen
-       in if len < 2 ^ (16 :: Int) - 3 && len <= paddedLen - 2
-            then (padded >>= C.unPad) == Right b
-            else padded == Left C.CryptoLargeMsgError
-    it "pad should fail on large string" $ do
-      C.pad "abc" 5 `shouldBe` Right "\000\003abc"
-      C.pad "abc" 4 `shouldBe` Left C.CryptoLargeMsgError
-      let s = B.replicate 65533 'a'
-      (C.pad s 65535 >>= C.unPad) `shouldBe` Right s
-      C.pad (B.replicate 65534 'a') 65536 `shouldBe` Left C.CryptoLargeMsgError
-      C.pad (B.replicate 65535 'a') 65537 `shouldBe` Left C.CryptoLargeMsgError
-    it "unpad should fail on invalid string" $ do
-      C.unPad "\000\000" `shouldBe` Right ""
-      C.unPad "\000" `shouldBe` Left C.CryptoInvalidMsgError
-      C.unPad "" `shouldBe` Left C.CryptoInvalidMsgError
-    it "unpad should fail on shorter string" $ do
-      C.unPad "\000\003abc" `shouldBe` Right "abc"
-      C.unPad "\000\003ab" `shouldBe` Left C.CryptoInvalidMsgError
-  describe "Ed signatures" $ do
-    describe "Ed25519" $ testSignature C.SEd25519
-    describe "Ed448" $ testSignature C.SEd448
-  describe "DH X25519 + cryptobox" $
-    testDHCryptoBox
-  describe "X509 key encoding" $ do
-    describe "Ed25519" $ testEncoding C.SEd25519
-    describe "Ed448" $ testEncoding C.SEd448
-    describe "X25519" $ testEncoding C.SX25519
-    describe "X448" $ testEncoding C.SX448
-
-testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec
-testSignature alg = it "should sign / verify string" . ioProperty $ do
-  (k, pk) <- C.generateSignatureKeyPair alg
-  pure $ \s -> let b = encodeUtf8 $ T.pack s in C.verify k (C.sign pk b) b
-
-testDHCryptoBox :: Spec
-testDHCryptoBox = it "should encrypt / decrypt string" . ioProperty $ do
-  (sk, spk) <- C.generateKeyPair'
-  (rk, rpk) <- C.generateKeyPair'
-  nonce <- C.randomCbNonce
-  pure $ \(s, pad) ->
-    let b = encodeUtf8 $ T.pack s
-        paddedLen = B.length b + abs pad + 2
-        cipher = C.cbEncrypt (C.dh' rk spk) nonce b paddedLen
-        plain = C.cbDecrypt (C.dh' sk rpk) nonce =<< cipher
-     in isRight cipher && cipher /= plain && Right b == plain
-
-testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
-testEncoding alg = it "should encode / decode key" . ioProperty $ do
-  (k, pk) <- C.generateKeyPair alg
-  pure $ \(_ :: Int) ->
-    C.decodePubKey (C.encodePubKey k) == Right k
-      && C.decodePrivKey (C.encodePrivKey pk) == Right pk

tests/CoreTests/ProtocolErrorTests.hs

@@ -1,14 +1,9 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module CoreTests.ProtocolErrorTests where
 
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
-import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Agent.Protocol (AgentErrorType)
 import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (ErrorType)
+import Simplex.Messaging.Encoding.String
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -16,13 +11,9 @@ import Test.QuickCheck
 protocolErrorTests :: Spec
 protocolErrorTests = modifyMaxSuccess (const 1000) $ do
   describe "errors parsing / serializing" $ do
-    it "should parse SMP protocol errors" . property $ \(err :: AgentErrorType) ->
-      errServerHasSpaces err
-        || parseAll strP (strEncode err) == Right err
-    it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) ->
-      errServerHasSpaces err
-        || parseAll strP (strEncode err) == Right err
-  where
-    errServerHasSpaces = \case
-      BROKER srv _ -> ' ' `B.elem` encodeUtf8 (T.pack srv)
-      _ -> False
+    it "should parse SMP protocol errors" . property $ \err ->
+      parseAll strP (strEncode err)
+        == Right (err :: ErrorType)
+    it "should parse SMP agent errors" . property $ \err ->
+      parseAll strP (strEncode err)
+        == Right (err :: AgentErrorType)

tests/CoreTests/RetryIntervalTests.hs

@@ -1,61 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module CoreTests.RetryIntervalTests where
-
-import Control.Concurrent.STM
-import Control.Monad (when)
-import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
-import Simplex.Messaging.Agent.RetryInterval
-import Test.Hspec
-
-retryIntervalTests :: Spec
-retryIntervalTests = do
-  describe "Retry interval with 2 modes and lock" $ do
-    testRetryIntervalSameMode
-    testRetryIntervalSwitchMode
-
-testRI :: RetryInterval2
-testRI =
-  RetryInterval2
-    { riSlow =
-        RetryInterval
-          { initialInterval = 20000,
-            increaseAfter = 40000,
-            maxInterval = 40000
-          },
-      riFast =
-        RetryInterval
-          { initialInterval = 10000,
-            increaseAfter = 20000,
-            maxInterval = 40000
-          }
-    }
-
-testRetryIntervalSameMode :: Spec
-testRetryIntervalSameMode =
-  it "should increase elapased time and interval when the mode stays the same" $ do
-    lock <- newEmptyTMVarIO
-    intervals <- newTVarIO []
-    ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \loop -> do
-      ints <- addInterval intervals ts
-      when (length ints < 9) $ loop RIFast
-    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4]
-
-testRetryIntervalSwitchMode :: Spec
-testRetryIntervalSwitchMode =
-  it "should increase elapased time and interval when the mode stays the same" $ do
-    lock <- newEmptyTMVarIO
-    intervals <- newTVarIO []
-    ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \loop -> do
-      ints <- addInterval intervals ts
-      when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow
-    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4]
-
-addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
-addInterval intervals ts = do
-  ts' <- getCurrentTime
-  atomically $ do
-    int :: Int <- truncate . (* 100) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
-    stateTVar intervals $ \ints -> (int : ints, int : ints)

tests/NtfClient.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -18,19 +17,18 @@ module NtfClient where
 import Control.Monad
 import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
+import Crypto.Random
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
-import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
-import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -44,6 +42,7 @@ import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.Server
+import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
@@ -51,7 +50,7 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 import UnliftIO.Timeout (timeout)
 
-testHost :: NonEmpty TransportHost
+testHost :: HostName
 testHost = "localhost"
 
 ntfTestPort :: ServiceName
@@ -63,13 +62,9 @@ apnsTestPort = "6010"
 testKeyHash :: C.KeyHash
 testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 
-ntfTestStoreLogFile :: FilePath
-ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
-
-testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
-testNtfClient client = do
-  Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
-  runTransportClient defaultTransportClientConfig host ntfTestPort (Just testKeyHash) $ \h ->
+testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
+testNtfClient client =
+  runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -86,34 +81,21 @@ ntfServerCfg =
       smpAgentCfg = defaultSMPClientAgentConfig,
       apnsConfig =
         defaultAPNSPushClientConfig
-          { apnsPort = apnsTestPort,
+          { apnsHost = "localhost",
+            apnsPort = apnsTestPort,
             http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
           },
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
-      storeLogFile = Nothing,
-      resubscribeDelay = 1000,
       -- CA certificate private key is not needed for initialization
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt",
-      -- stats config
-      logStatsInterval = Nothing,
-      logStatsStartTime = 0,
-      serverStatsLogFile = "tests/ntf-server-stats.daily.log",
-      serverStatsBackupFile = Nothing,
-      logTLSErrors = True
+      certificateFile = "tests/fixtures/server.crt"
     }
 
-withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
-withNtfServerStoreLog t = withNtfServerCfg t ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile}
-
-withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
-withNtfServerThreadOn t port' = withNtfServerCfg t ntfServerCfg {transports = [(port', t)]}
-
-withNtfServerCfg :: ATransport -> NtfServerConfig -> (ThreadId -> IO a) -> IO a
-withNtfServerCfg t cfg =
+withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withNtfServerThreadOn t port' =
   serverBracket
-    (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
+    (\started -> runNtfServerBlocking started ntfServerCfg {transports = [(port', t)]})
     (pure ())
 
 serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
@@ -129,13 +111,13 @@ serverBracket process afterProcess f = do
         Nothing -> error $ "server did not " <> s
         _ -> pure ()
 
-withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a
+withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
 withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 
-withNtfServer :: ATransport -> IO a -> IO a
+withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
 withNtfServer t = withNtfServerOn t ntfTestPort
 
-runNtfTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
+runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
 runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 
 ntfServerTest ::
@@ -148,10 +130,10 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' h (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+      Right () <- tPut h (sig, t')
       pure ()
     tGet' h = do
-      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
+      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
@@ -178,8 +160,7 @@ apnsMockServerConfig =
       serverSupported = http2TLSParams,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt",
-      logTLSErrors = True
+      certificateFile = "tests/fixtures/server.crt"
     }
 
 withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()

tests/NtfServerTests.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -10,9 +9,9 @@
 module NtfServerTests where
 
 import Control.Concurrent (threadDelay)
+import Control.Monad.Except (runExceptT)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
-import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
@@ -24,20 +23,15 @@ import ServerTests
     samplePubKey,
     sampleSig,
     signSendRecv,
-    tGet1,
-    tPut1,
     (#==),
     _SEND',
     pattern Resp,
   )
-import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
-import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
-import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
 import Simplex.Messaging.Transport
 import Test.Hspec
@@ -53,9 +47,9 @@ ntfSyntaxTests (ATransport t) = do
   it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
   describe "NEW" $ do
     it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
-    it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
-    it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
-    it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
+    it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
+    it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
+    it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
   where
     (>#>) ::
       Encoding smp =>
@@ -70,14 +64,15 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
 sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
 sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut1 h (sgn, t)
-  tGet1 h
+  Right () <- tPut h (sgn, t)
+  tGet h
 
 signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
 signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut1 h (Just $ C.sign pk t, t)
-  tGet1 h
+  Right sig <- runExceptT $ C.sign pk t
+  Right () <- tPut h (Just sig, t)
+  tGet h
 
 (.->) :: J.Value -> J.Key -> Either String ByteString
 v .-> key =
@@ -91,12 +86,12 @@ testNotificationSubscription (ATransport t) =
     (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
     (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = DeviceToken PPApns "abcd"
     withAPNSMockServer $ \APNSMockServer {apnsQ} ->
       smpTest2 t $ \rh sh ->
         ntfTest t $ \nh -> do
           -- create queue
-          (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
+          (sId, rId, rKey, _dhShared) <- createAndSecureQueue rh sPub
           -- register and verify token
           RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", TNEW $ NewNtfTkn tkn tknPub dhPub)
           APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <-
@@ -109,11 +104,9 @@ testNotificationSubscription (ATransport t) =
           RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
           RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
           -- enable queue notifications
-          (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- C.generateKeyPair'
-          Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey)
+          Resp "3" _ (NID nId) <- signSendRecv rh rKey ("3", rId, NKEY nPub)
           let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
               q = SMPQueueNtf srv nId
-              rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
           RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey)
           -- send message
           threadDelay 50000
@@ -121,45 +114,14 @@ testNotificationSubscription (ATransport t) =
           -- receive notification
           APNSMockRequest {notification, sendApnsResponse = send'} <- atomically $ readTBQueue apnsQ
           let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification
+              Right checkMessage = ntfData' .-> "checkMessage"
               Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
-              Right message = ntfData' .-> "message"
-              Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
-              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} =
-                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
-              Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta
-              Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
-          smpServer `shouldBe` srv
-          notifierId `shouldBe` nId
+              Right smpQueueURI = C.cbDecrypt dhSecret nonce' checkMessage
+          smpQueueURI `shouldBe` strEncode srv <> "/" <> strEncode nId
           send' APNSRespOk
           -- receive message
-          Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
-          Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
-          mId1 `shouldBe` msgId
-          mTs `shouldBe` msgTs
-          (msgBody, "hello") #== "delivered from queue"
+          let dec _nonce = C.cbDecrypt _dhShared (C.cbNonce _nonce)
+          Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh
+          (dec mId1 msg1, Right "hello") #== "delivered from queue"
           Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
           pure ()
-          -- replace token
-          let tkn' = DeviceToken PPApnsTest "efgh"
-          RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
-          tId `shouldBe` tId'
-          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}, sendApnsResponse = send2} <-
-            atomically $ readTBQueue apnsQ
-          send2 APNSRespOk
-          let Right verification2 = ntfData2 .-> "verification"
-              Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce"
-              Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2
-          RespNtf "8" _ NROk <- signSendRecvNtf nh tknKey ("8", tId, TVFY code2)
-          RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK)
-          -- send message
-          Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2")
-          APNSMockRequest {notification = notification3, sendApnsResponse = send3} <- atomically $ readTBQueue apnsQ
-          let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3
-              Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
-              Right message3 = ntfData3 .-> "message"
-              Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
-              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} =
-                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
-          smpServer3 `shouldBe` srv
-          notifierId3 `shouldBe` nId
-          send3 APNSRespOk