wip

.github/workflows/build.yml

@@ -19,9 +19,9 @@ jobs:
       - name: Setup Stack
         uses: haskell/actions/setup@v1
         with:
-          ghc-version: "8.10.7"
+          ghc-version: '8.10.7'
           enable-stack: true
-          stack-version: "latest"
+          stack-version: 'latest'
 
       - name: Cache dependencies
         uses: actions/cache@v2
@@ -36,7 +36,6 @@ jobs:
           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')
@@ -74,7 +73,6 @@ jobs:
           files: |
             LICENSE
             smp-server-ubuntu-20_04-x86-64
-            ntf-server-ubuntu-20_04-x86-64
           fail_on_unmatched_files: true
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

CHANGELOG.md

@@ -1,106 +1,24 @@
-# 2.3.0
-
-SMP server:
-
-- Save and restore undelivered messages, to avoid losing them. To save messages the server has to be stopped with SIGINT signal, if it is stopped with SIGTERM undelivered messages would not be saved.
-
-# 2.2.0
-
-SMP server:
-
-- Fix sockets/threads/memory leak
-
-SMP agent:
-
-- Support stopping and resuming agent with `disconnectAgentClient` / `resumeAgentClient`
-
-# 2.1.1
-
-SMP server:
-
-- gracefully close sockets on client disconnection
-- CLI warning when deleting server configuration
-
-# 2.1.0
-
-SMP server:
-
-- configuration to expire inactive clients in ini file, increased TTL and check interval for client expiration
-
-# 2.0.0
-
-Push notifications server (beta):
-
-- supports APNS
-- manage device tokens verification via notification delivery
-- sending periodic background notification to check messages (not more frequent than every 20 min)
-
-SMP server:
-
-- disconnect inactive clients after some period
-- remove undelivered messages after 30 days
-- log aggregate usage daily stats: only the number of queues created/secured/deleted/used and messages sent/delivered is logged, as one line per day, so we can plan server capacity and diagnose any problems.
-
-SMP agent:
-
-- manage device tokens and notification server connection
-- DOWN/UP events to the agent user about server disconnections/reconnections are now sent once per server
-
-# 1.1.0
-
-SMP server:
-
-- message TTL and periodic deletion of old messages
-- configuration to prevent creation of the new queues
-
-SMP agent:
-
-- asynchronous connection handshake
-- configurable SMP servers at run-time
-- use TCP keep-alive for connection stability
-- improve stability of connection subscriptions
-- auto-vacuum DB to remove deleted records
-
-# 1.0.3
-
-SMP server:
-
-- Reduce server message queue quota to 128 messages.
-
-SMP agent:
-
-- Add "yes to migrations" option.
-- Make new SMP client attempt to reconnect on network error.
-- Reduce connection handshake expiration to 2 days.
-
-JSON encoding of types used in simplex-chat, some other minor adjustments.
-
 # 1.0.2
 
 General:
-
 - Enable TLS 1.3 parameters for TLS handshake (server and client).
 - Switch from hs-tls fork to original repo now that it supports getFinished and getPeerFinished APIs for both TLS 1.2 and TLS 1.3.
 
 SMP server:
-
 - Perform TLS handshake in a separate thread per-connection.
 
 SMP agent:
-
 - Cease attempts to send HELLO after one week timeout.
 - Coalesce requests to connect to SMP servers, to have 1 connection per server.
 
 # 1.0.1
 
 SMP server:
-
 - Explicitly set line buffering in stdout/stderr to log each line when output is redirected to files.
 
 # 1.0.0
 
 Security and privacy improvements:
-
 - Faster and more secure 2-layer E2E encryption with additional encryption layer between servers and recipients:
   - application messages in each duplex connection (managed by SMP agents - see [overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md)) are encrypted using [double-ratchet algorithm](https://www.signal.org/docs/specifications/doubleratchet/), providing forward secrecy and break-in recovery. This layer uses two Curve448 keys per client for [X3DH key agreement](https://www.signal.org/docs/specifications/x3dh/), SHA512 based HKDFs and AES-GCM AEAD encryption.
   - SMP client messages are additionally E2E encrypted in each SMP queue to avoid cipher-text correlation of messages sent via multiple redundant queues (that will be supported soon). This and the next layer use [NaCl crypto_box algorithm](https://nacl.cr.yp.to/index.html) with XSalsa20Poly1305 cipher and Curve25519 keys for DH key agreement.
@@ -113,16 +31,13 @@ Security and privacy improvements:
 - Server identity verification via server offline certificate fingerprints included in SMP server addresses.
 
 New functionality:
-
 - Support for notification servers with new SMP commands: `NKEY`/`NID`, `NSUB`/`NMSG`.
 
 Efficiency improvements:
-
 - Binary protocol encodings to reduce overhead from circa 15% to approximately 3.7% of transmitted application message size, with only 2.2% overhead for SMP protocol messages.
 - More performant cryptographic algorithms.
 
 For more information about SimpleX:
-
 - [SimpleX overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md).
 - [SimpleX chat v1 announcement](https://github.com/simplex-chat/simplex-chat/blob/master/blog/20220112-simplex-chat-v1-released.md).
 

README.md

@@ -27,16 +27,14 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
 
 ### SMP server
 
-[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.
+[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies, including low power/low memory devices.
 
-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]`.
+To initialize the server use `smp-server init` 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]`.
 
 SMP server uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues.
 
 To enable store log, initialize server using `smp-server -l` command, or modify `smp-server.ini` created during initialization (uncomment `enable: on` option in the store log section). Use `smp-server --help` for other usage tips.
 
-Starting from version 2.3.0, when store log is enabled, the server would also enable saving undelivered messages on exit and restoring them on start. This can be disabled via a separate setting `restore_messages` in `smp-server.ini` file. Saving messages would only work if the server is stopped with SIGINT signal (keyboard interrupt), if it is stopped with SIGTERM signal the messages would not be saved.
-
 > **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](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
@@ -63,7 +61,6 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 ### SMP client library
 
 [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.
 - automatically send keep-alive commands.
@@ -90,26 +87,6 @@ You can either run your own SMP server locally or deploy using [Linode StackScri
 
 It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
 
-## Deploy SMP server on Linux
-
-You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
-
-- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
-
-  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/):
-
-  ```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.
-
-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="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
@@ -121,11 +98,11 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 - Create a Linode account or login with an already existing one.
 - Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode".
 - You can optionally configure the following parameters:
-  - SMP Server store log flag for queue persistence on server restart, recommended.
-  - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
-    - read/write for "linodes"
-    - read/write for "domains"
-  - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
+    - SMP Server store log flag for queue persistence on server restart, recommended.
+    - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
+      - read/write for "linodes"
+      - read/write for "domains"
+    - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
 - Choose the region and plan, Shared CPU Nanode with 1Gb is sufficient.
 - Provide ssh key to be able to connect to your Linode via ssh. If you haven't provided a Linode API token this step is required to login to your Linode and get the server's fingerprint either from the welcome message or from the file `/etc/opt/simplex/fingerprint` after server starts. See [Linode's guide on ssh](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) .
 - Deploy your Linode. After it starts wait for SMP server to start and for tags to appear (if a Linode API token was provided). It may take up to 5 minutes depending on the connection speed on the Linode. Connecting Linode IP address to provided domain name may take some additional time.

apps/ntf-server/Main.hs

@@ -1,74 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Main where
-
-import Control.Logger.Simple
-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"
-
-logPath :: FilePath
-logPath = "/var/opt/simplex-notifications"
-
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
-
-main :: IO ()
-main = do
-  setLogLevel LogDebug -- change to LogError in production
-  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

@@ -6,19 +6,12 @@ module Main where
 
 import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Server (runSMPAgent)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
-cfg = defaultAgentConfig
-
-servers :: InitialAgentServers
-servers =
-  InitialAgentServers
-    { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = []
-    }
+cfg = defaultAgentConfig {smpServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -27,4 +20,4 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
+  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg

apps/smp-server/Main.hs

@@ -1,107 +1,319 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Main where
 
-import Control.Logger.Simple
-import Data.Functor (($>))
-import Data.Ini (lookupValue)
+import Control.Monad.Except
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+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.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)
+import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath)
+import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), simplexMQVersion)
+import Simplex.Messaging.Transport.Server (loadFingerprint)
+import Simplex.Messaging.Transport.WebSockets (WS)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
+import System.Exit (exitFailure)
 import System.FilePath (combine)
+import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile)
+import System.Process (readCreateProcess, shell)
+import Text.Read (readMaybe)
 
-cfgPath :: FilePath
-cfgPath = "/etc/opt/simplex"
+cfgDir :: FilePath
+cfgDir = "/etc/opt/simplex"
 
-logPath :: FilePath
-logPath = "/var/opt/simplex"
+logDir :: FilePath
+logDir = "/var/opt/simplex"
 
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+iniFile :: FilePath
+iniFile = combine cfgDir "smp-server.ini"
+
+storeLogFile :: FilePath
+storeLogFile = combine logDir "smp-server-store.log"
+
+caKeyFile :: FilePath
+caKeyFile = combine cfgDir "ca.key"
+
+caCrtFile :: FilePath
+caCrtFile = combine cfgDir "ca.crt"
+
+serverKeyFile :: FilePath
+serverKeyFile = combine cfgDir "server.key"
+
+serverCrtFile :: FilePath
+serverCrtFile = combine cfgDir "server.crt"
+
+fingerprintFile :: FilePath
+fingerprintFile = combine cfgDir "fingerprint"
 
 main :: IO ()
 main = do
-  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
+  getCliCommand >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`."
+        _ -> initializeServer opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions)
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`."
+    Delete -> cleanup >> putStrLn "Deleted configuration and log files"
 
-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
-              }
+exitError :: String -> IO ()
+exitError msg = putStrLn msg >> 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 :: IO CliCommand
+getCliCommand =
+  customExecParser
+    (prefs showHelpOnEmpty)
+    ( info
+        (helper <*> versionOption <*> cliCommandP)
+        (header version <> fullDesc)
+    )
+  where
+    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
+
+cliCommandP :: Parser CliCommand
+cliCommandP =
+  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
+    initP :: Parser CliCommand
+    initP =
+      Init
+        <$> ( InitOptions
+                <$> switch
+                  ( long "store-log"
+                      <> short 'l'
+                      <> help "Enable store log for SMP queues 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 Subject Alternative Name for TLS online certificate, \
+                        \also used as Common Name 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 and Subject Alternative Name for TLS online certificate"
+                      <> showDefault
+                      <> metavar "FQDN"
+                  )
+            )
+
+initializeServer :: InitOptions -> IO ()
+initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+  cleanup
+  createDirectoryIfMissing True cfgDir
+  createDirectoryIfMissing True logDir
+  createX509
+  fp <- saveFingerprint
+  createIni
+  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server."
+  printServiceInfo fp
+  warnCAPrivateKeyFile
+  where
+    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 caCrtFile
+      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
+      pure fp
+
+    createIni = do
+      writeFile iniFile $
+        "[STORE_LOG]\n\
+        \# The server uses STM memory to store SMP queues and messages,\n\
+        \# that will be lost on restart (e.g., as with redis).\n\
+        \# This option enables saving SMP queues to append only log,\n\
+        \# and restoring them when the server is started.\n\
+        \# Log is compacted on start (deleted queues are removed).\n\
+        \# The messages in the queues are not logged.\n"
+          <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+          <> "[TRANSPORT]\n\
+             \port: 5223\n\
+             \websockets: off\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,
+    port :: ServiceName,
+    enableWebsockets :: Bool
+  }
+
+-- TODO ? properly parse ini as a whole
+mkIniOptions :: Ini -> IniOptions
+mkIniOptions ini =
+  IniOptions
+    { enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",
+      port = T.unpack $ strict "TRANSPORT" "port",
+      enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"
+    }
+  where
+    strict :: String -> String -> T.Text
+    strict section key =
+      fromRight (error ("no key " <> key <> " in section " <> section)) $
+        lookupValue (T.pack section) (T.pack key) ini
+
+runServer :: IniOptions -> IO ()
+runServer IniOptions {enableStoreLog, port, enableWebsockets} = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  fp <- checkSavedFingerprint
+  printServiceInfo fp
+  storeLog <- openStoreLog
+  let cfg = mkServerConfig storeLog
+  printServerConfig cfg
+  runSMPServer cfg
+  where
+    checkSavedFingerprint = do
+      savedFingerprint <- loadSavedFingerprint
+      Fingerprint fp <- loadFingerprint caCrtFile
+      when (B.pack savedFingerprint /= strEncode fp) $
+        exitError "Stored fingerprint is invalid."
+      pure fp
+
+    mkServerConfig storeLog =
+      ServerConfig
+        { transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],
+          tbqSize = 16,
+          serverTbqSize = 128,
+          msgQueueQuota = 256,
+          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,
+          storeLog
         }
+
+    openStoreLog :: IO (Maybe (StoreLog 'ReadMode))
+    openStoreLog =
+      if enableStoreLog
+        then Just <$> openReadStoreLog storeLogFile
+        else pure Nothing
+
+    printServerConfig ServerConfig {storeLog, transports} = do
+      putStrLn $ case storeLog of
+        Just s -> "Store log: " <> storeLogFilePath s
+        Nothing -> "Store log disabled."
+      forM_ transports $ \(p, ATransport t) ->
+        putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
+
+cleanup :: IO ()
+cleanup = do
+  deleteDirIfExists cfgDir
+  deleteDirIfExists logDir
+  where
+    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
+
+printServiceInfo :: ByteString -> IO ()
+printServiceInfo fpStr = do
+  putStrLn version
+  B.putStrLn $ "Fingerprint: " <> strEncode fpStr
+
+version :: String
+version = "SMP server v" <> simplexMQVersion
+
+loadSavedFingerprint :: IO String
+loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine

cabal.project

@@ -2,5 +2,5 @@ packages: .
 
 source-repository-package
     type: git
-    location: https://github.com/simplex-chat/aeson.git
+    location: git://github.com/simplex-chat/aeson.git
     tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7

package.yaml

@@ -1,7 +1,7 @@
 name: simplexmq
-version: 2.3.1
+version: 1.0.2
 synopsis: SimpleXMQ message broker
-description: |
+description:  |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
   <./docs/Simplex-Messaging-Client.html client> and
   <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols:
@@ -31,7 +31,6 @@ dependencies:
   - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
   - bytestring == 0.10.*
-  - case-insensitive == 1.2.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
   - containers == 0.6.*
@@ -42,17 +41,14 @@ dependencies:
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 3.0.*
   - generic-random >= 1.3 && < 1.5
-  - ini == 0.4.*
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
-  - network >= 3.1.2.7 && < 3.2
+  - network == 3.1.*
   - network-transport == 0.5.*
-  - optparse-applicative >= 0.15 && < 0.17
+  - postgresql-simple == 0.6.*
   - QuickCheck == 2.14.*
-  - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
   - sqlite-simple == 0.4.*
@@ -60,9 +56,7 @@ dependencies:
   - template-haskell == 2.16.*
   - text == 1.2.*
   - time == 1.9.*
-  - time-compat == 1.9.*
-  - time-manager == 0.0.*
-  - tls >= 1.6.0 && < 1.7
+  - tls >= 1.5.7 && < 1.6
   - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
@@ -71,17 +65,6 @@ dependencies:
   - x509-store == 1.6.*
   - x509-validation == 1.6.*
 
-flags:
-  swift:
-    description: Enable swift JSON format
-    manual: True
-    default: False
-
-when:
-  - condition: flag(swift)
-    cpp-options:
-      - -DswiftJSON
-
 library:
   source-dirs: src
 
@@ -90,14 +73,9 @@ executables:
     source-dirs: apps/smp-server
     main: Main.hs
     dependencies:
-      - simplexmq
-    ghc-options:
-      - -threaded
-
-  ntf-server:
-    source-dirs: apps/ntf-server
-    main: Main.hs
-    dependencies:
+      - ini == 0.4.*
+      - optparse-applicative >= 0.15 && < 0.17
+      - process == 1.6.*
       - simplexmq
     ghc-options:
       - -threaded

protocol/diagrams/notifications/register-token.mmd

@@ -1,30 +0,0 @@
-sequenceDiagram
-  participant M as mobile app
-  participant C as chat core
-  participant A as agent
-  participant P as push server
-  participant APN as APN
-
-  note over M, APN: get device token
-  M ->> APN: registerForRemoteNotifications()
-  APN ->> M: device token
-
-  note over M, P: register device token with push server
-  M ->> C: /_ntf register <token>
-  C ->> A: registerNtfToken(<token>)
-  A ->> P: TNEW
-  P ->> A: ID (tokenId)
-  A ->> C: registered
-  C ->> M: registered
-
-  note over M, APN: verify device token
-  P ->> APN: E2E encrypted code<br>in background<br>notification
-  APN ->> M: deliver background notification with e2ee verification token
-  M ->> C: /_ntf verify <e2ee code>
-  C ->> A: verifyNtfToken(<e2ee code>)
-  A ->> P: TVFY code
-  P ->> A: OK / ERR
-  A ->> C: verified
-  C ->> M: verified
-
-  note over M, APN: now token ID can be used

protocol/diagrams/notifications/subscription.mmd

@@ -1,40 +0,0 @@
-sequenceDiagram
-  participant M as mobile app
-  participant C as chat core
-  participant A as agent
-  participant S as SMP server
-  participant N as NTF server
-  participant APN as APN
-
-  note over M, APN: register subscription
-
-  alt register existing
-    M -->> A: on /_ntf register, for subscribed queues
-  else create new connection
-    A -->> S: NEW / JOIN
-    note over A, S: ...<br>Connection handshake<br>...
-    S -->> A: CON
-  end
-  A ->> S: NKEY nKey
-  S ->> A: NID nId
-  A ->> N: SNEW tknId dhKey (smpServer, nId, nKey)
-  N ->> A: ID subId dhKey
-  N ->> S: NSUB nId
-  S ->> N: OK [/ NMSG]
-
-  note over M, APN: notify about message
-
-  S ->> N: NMSG
-  N ->> APN: APNSMutableContent<br>ntfQueue, nonce
-  APN ->> M: UNMutableNotificationContent
-  note over M, S: ...<br>Client awaken, message is received<br>...
-  S ->> M: message
-  note over M: mutate notification
-
-  note over M, APN: change APN token
-
-  APN ->> M: new device token
-  M -->> C: /_ntf_sub update tkn
-  C -->> A: updateNtfToken()
-  A -->> N: TUPD tknId newDeviceToken
-  note over M, N: ...<br>Verify token<br>...

protocol/simplex-messaging.md

@@ -770,7 +770,7 @@ The syntax for error responses:
 ```abnf
 error = %s"ERR " errorType
 errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
-cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY"
+cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
 ```
 
 Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).

protocol/simplex-uri-request.txt

@@ -13,6 +13,6 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
 
 References:
 The syntax for connection requests in the latest version of SimpleX Agent Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#connection-request
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/agent-protocol.md#connection-request
 SimpleX Messaging Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md

protocol/smp-uri-request.txt

@@ -13,4 +13,4 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
 
 References:
 The syntax for message queue URIs in the latest version of SimpleX Messaging Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#smp-queue-uri
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md#smp-queue-uri

rfcs/2022-03-22-nofication-server.md

@@ -1,91 +0,0 @@
-# Notification server
-
-## Background and motivation
-
-SimpleX Chat clients should receive message notifications when not being online and/or subscribed to SMP servers.
-
-To avoid revealing identities of clients directly to SMP servers via any kind of push notification tokens, a new party called SimpleX Notification Server is introduced to act as a service for subscribing to SMP server queue notifications on behalf of clients and sending push notifications to them.
-
-## Proposal
-
-TCP service using the same TLS transport as SMP server, with the fixed size blocks (256 bytes?) and the following set of commands:
-
-### Protocol
-
-#### Create subscription
-
-Command:
-
-`%s"CREATE " ntfSmpQueueURI ntfPrivateKey token subPublicKey`
-
-Response:
-
-`s%"OK"`
-
-#### Check subscription status
-
-Command:
-
-`%s"CHECK " ntfSmpQueueURI`
-
-Response:
-
-```abnf
-statusResp = %s"STAT " status
-status = %s"ERR AUTH" / "ERR SMP AUTH" / %s"ERR SMP TIMEOUT" / %s"ACTIVE" / %s"PENDING"
-```
-
-#### Update subscription device token
-
-Command:
-
-`%s"TOKEN " ntfSmpQueueURI token`
-
-Response:
-
-`s%"OK" / %s"ERR"`
-
-#### Delete subscription (e.g. when deleting the queue or moving to another notification server)
-
-Command:
-
-`%s"DELETE " SP ntfSmpQueueURI`
-
-Response:
-
-`s%"OK" / %s"ERR"`
-
-### Agent schema changes
-
-See [migration](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220322_notifications.hs)
-
-### Agent code
-
-```haskell
-data NtfOptions = NtfOptions
-  { ntfServer :: Server, -- same type as for SMP servers, probably will be renamed
-    ntfToken :: ByteString,
-    ntfInitialCheckDelay :: Int, -- initial check delay after subscription is created, seconds
-    ntfPeriodicCheckInterval :: Int -- subscription check interval, seconds
-  }
-
-data AgentConfig = AgentConfig {
-  -- ...
-  initialNtfOpts :: Maybe NtfOptions
-  -- ...
-  }
-
-data AgentClient = AgentClient {
-  -- ...
-  ntfOpts :: TVar (Maybe NtfOptions)
-  -- ...
-  }
-```
-
-A configuration parameter `initialNtfOpts :: Maybe NtfOptions` - if it is set or changes the agent would automatically manage subscriptions as SMP queues are subscribed/created/deleted and as the token or server changes.
-
-There will be a method to update notifications configuration in case token or server changes.
-
-All subscriptions will be managed in a separate subscription management loop, that would always take the earliest un-updated subscription that requires some action (ntf_sub_action column) and perform this action - the table of subscription would serve both as the table of existing subscriptions and required actions.
-
-E.g. if the queue is subscribed and there is no notification subscription, it will be created in the table with "create" action, and the loop would create it and schedule "check" action on it.

rfcs/2022-04-20-smp-conf-timeout-recovery.md

@@ -1,21 +0,0 @@
-# SMP confirmation timeout recovery
-
-## Problem
-
-When sending an SMP confirmation a network timeout can lead to the following race condition:
-- server receives the confirmation while the joining party fails to receive the server's response;
-- joining party deletes the connection together with credentials sent in the confirmation for securing the queue;
-- initiating party will receive the confirmation from the server and secure the queue;
-- on subsequent attempt to join via the same invitation link initiating party will generate new credentials and fail authorization.
-
-This renders the joining party permanently unable to join via that invitation link and complete the connection.
-
-## Solution
-
-A possible solution is to keep and try to reuse same credentials on subsequent attempts:
-- joining party has to remember invitation link when saving the connection;
-- if SMP confirmation fails due to network timeout joining party doesn't delete the connection and keeps the credentials;
-- when joining, joining party checks whether such invitation link was already used for a connection, if yes:
-  - joining party tries to send SMP confirmation with the same credentials;
-  - if this SMP confirmation fails with authorization error (for example it can happen due to race condition explained above) joining party tries to send HELLO message;
-  - if HELLO message fails with authorization error (it can happen if connection was deleted or secured with different credentials), the recovery is no longer possible and connection can be deleted.

scripts/smp-server-digitalocean-droplet/README.md

@@ -16,8 +16,3 @@ brew install hashicorp/tap/packer
 cd ./scripts/smp-server-digitalocean-droplet
 DIGITALOCEAN_TOKEN=$YOUR_TOKEN packer build -on-error=ask -color=false ./marketplace-image.json
 ```
-
-**TODO** (see Linode script)
-
-- Increase file descriptors limit
-- Configure Restart for systemd service

scripts/smp-server-linode.sh

@@ -44,12 +44,6 @@ 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/bin"
 binary="$bin_dir/smp-server"
@@ -157,11 +151,6 @@ Description=SMP server
 [Service]
 Type=simple
 ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
-KillSignal=SIGINT
-Restart=always
-RestartSec=10
-LimitNOFILE=1000000
-LimitNOFILESoft=1000000
 
 [Install]
 WantedBy=multi-user.target

scripts/update-smp-server.sh

@@ -1,12 +0,0 @@
-#!/bin/bash
-
-# systemd has to be configured to use SIGINT to save and restore undelivered messages after restart.
-# Add this to [Service] section:
-# KillSignal=SIGINT
-curl -L -o /opt/simplex/bin/smp-server-new https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64
-systemctl stop smp-server
-cp /var/opt/simplex/smp-server-store.log /var/opt/simplex/smp-server-store.log.bak
-mv /opt/simplex/bin/smp-server /opt/simplex/bin/smp-server-old
-mv /opt/simplex/bin/smp-server-new /opt/simplex/bin/smp-server
-chmod +x /opt/simplex/bin/smp-server
-systemctl start smp-server

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        2.3.1
+version:        1.0.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -27,58 +27,39 @@ extra-source-files:
     README.md
     CHANGELOG.md
 
-flag swift
-  description: Enable swift JSON format
-  manual: True
-  default: False
-
 library
   exposed-modules:
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
+      Simplex.Messaging.Agent.Env.Postgres
       Simplex.Messaging.Agent.Env.SQLite
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
       Simplex.Messaging.Agent.RetryInterval
       Simplex.Messaging.Agent.Server
       Simplex.Messaging.Agent.Store
+      Simplex.Messaging.Agent.Store.Postgres
+      Simplex.Messaging.Agent.Store.Postgres.Migrations
+      Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial
       Simplex.Messaging.Agent.Store.SQLite
       Simplex.Messaging.Agent.Store.SQLite.Migrations
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft
       Simplex.Messaging.Client
-      Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
       Simplex.Messaging.Crypto.Ratchet
       Simplex.Messaging.Encoding
       Simplex.Messaging.Encoding.String
-      Simplex.Messaging.Notifications.Client
-      Simplex.Messaging.Notifications.Protocol
-      Simplex.Messaging.Notifications.Server
-      Simplex.Messaging.Notifications.Server.Env
-      Simplex.Messaging.Notifications.Server.Push.APNS
-      Simplex.Messaging.Notifications.Server.Store
-      Simplex.Messaging.Notifications.Transport
       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.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.STM
       Simplex.Messaging.Server.StoreLog
-      Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Client
-      Simplex.Messaging.Transport.HTTP2
-      Simplex.Messaging.Transport.HTTP2.Client
-      Simplex.Messaging.Transport.HTTP2.Server
-      Simplex.Messaging.Transport.KeepAlive
       Simplex.Messaging.Transport.Server
       Simplex.Messaging.Transport.WebSockets
       Simplex.Messaging.Util
@@ -99,7 +80,6 @@ library
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -111,15 +91,12 @@ library
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
+    , network ==3.1.*
     , network-transport ==0.5.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , sqlite-simple ==0.4.*
@@ -127,9 +104,7 @@ library
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -137,69 +112,6 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  default-language: Haskell2010
-
-executable ntf-server
-  main-is: Main.hs
-  other-modules:
-      Paths_simplexmq
-  hs-source-dirs:
-      apps/ntf-server
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
-  build-depends:
-      QuickCheck ==2.14.*
-    , aeson ==2.0.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.7 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , cryptonite >=0.27 && <0.30
-    , cryptostore ==0.2.*
-    , data-default ==0.7.*
-    , 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.*
-    , iso8601-time ==0.1.*
-    , memory ==0.15.*
-    , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
-    , simplexmq
-    , sqlite-simple ==0.4.*
-    , stm ==2.5.*
-    , template-haskell ==2.16.*
-    , text ==1.2.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
-    , transformers ==0.5.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
-    , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 executable smp-agent
@@ -220,7 +132,6 @@ executable smp-agent
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -232,15 +143,12 @@ executable smp-agent
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
+    , network ==3.1.*
     , network-transport ==0.5.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
@@ -249,9 +157,7 @@ executable smp-agent
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -259,8 +165,6 @@ executable smp-agent
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 executable smp-server
@@ -281,7 +185,6 @@ executable smp-server
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -293,14 +196,14 @@ executable smp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
     , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
+    , network ==3.1.*
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
+    , postgresql-simple ==0.6.*
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
@@ -310,9 +213,7 @@ executable smp-server
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -320,8 +221,6 @@ executable smp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 test-suite smp-server-test
@@ -332,14 +231,10 @@ test-suite smp-server-test
       AgentTests.ConnectionRequestTests
       AgentTests.DoubleRatchetTests
       AgentTests.FunctionalAPITests
-      AgentTests.NotificationTests
-      AgentTests.SchemaDump
       AgentTests.SQLiteTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
       CoreTests.VersionRangeTests
-      NtfClient
-      NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
@@ -359,7 +254,6 @@ test-suite smp-server-test
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -373,15 +267,12 @@ test-suite smp-server-test
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
+    , network ==3.1.*
     , network-transport ==0.5.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
@@ -390,10 +281,8 @@ test-suite smp-server-test
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -401,6 +290,4 @@ test-suite smp-server-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010

src/Simplex/Messaging/Agent.hs

@@ -35,8 +35,7 @@ module Simplex.Messaging.Agent
     AgentMonad,
     AgentErrorMonad,
     getSMPAgentClient,
-    disconnectAgentClient,
-    resumeAgentClient,
+    disconnectAgentClient, -- used in tests
     withAgentLock,
     createConnection,
     joinConnection,
@@ -44,18 +43,10 @@ module Simplex.Messaging.Agent
     acceptContact,
     rejectContact,
     subscribeConnection,
-    resubscribeConnection,
     sendMessage,
     ackMessage,
     suspendConnection,
     deleteConnection,
-    setSMPServers,
-    setNtfServers,
-    registerNtfToken,
-    verifyNtfToken,
-    enableNtfCron,
-    checkNtfToken,
-    deleteNtfToken,
     logConnection,
   )
 where
@@ -66,7 +57,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
-import Data.Bifunctor (bimap, first, second)
+import Data.Bifunctor (first, second)
 import Data.ByteString.Char8 (ByteString)
 import Data.Composition ((.:), (.:.))
 import Data.Functor (($>))
@@ -77,25 +68,21 @@ import Data.Maybe (isJust)
 import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
-import Data.Word (Word16)
 import Database.SQLite.Simple (SQLError)
 import Simplex.Messaging.Agent.Client
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
-import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
+import Simplex.Messaging.Agent.Store.Postgres (PostgresStore)
+import Simplex.Messaging.Client (SMPServerTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Client
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..))
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody)
+import Simplex.Messaging.Protocol (MsgBody)
 import qualified Simplex.Messaging.Protocol as SMP
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM, ($>>=))
+import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM)
 import Simplex.Messaging.Version
 import System.Random (randomR)
 import UnliftIO.Async (async, race_)
@@ -103,20 +90,17 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
 -- | Creates an SMP agent client instance
-getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> m AgentClient
-getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
+getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient
+getSMPAgentClient cfg = newSMPAgentEnv cfg >>= runReaderT runAgent
   where
     runAgent = do
-      c <- getAgentClient initServers
+      c <- getAgentClient
       action <- async $ subscriber c `E.finally` disconnectAgentClient c
       pure c {smpSubscriber = action}
 
 disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m ()
 disconnectAgentClient c = closeAgentClient c >> logConnection c False
 
-resumeAgentClient :: MonadIO m => AgentClient -> m ()
-resumeAgentClient c = atomically $ writeTVar (active c) True
-
 -- |
 type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)
 
@@ -144,9 +128,6 @@ rejectContact c = withAgentEnv c .: rejectContact' c
 subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 subscribeConnection c = withAgentEnv c . subscribeConnection' c
 
-resubscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
-resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
-
 -- | Send message to the connection (SEND command)
 sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId
 sendMessage c = withAgentEnv c .: sendMessage' c
@@ -162,31 +143,6 @@ suspendConnection c = withAgentEnv c . suspendConnection' c
 deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 deleteConnection c = withAgentEnv c . deleteConnection' c
 
--- | Change servers to be used for creating new queues
-setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
-setSMPServers c = withAgentEnv c . setSMPServers' c
-
-setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
-setNtfServers c = withAgentEnv c . setNtfServers' c
-
--- | Register device notifications token
-registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-registerNtfToken c = withAgentEnv c . registerNtfToken' c
-
--- | Verify device notifications token
-verifyNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
-verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c
-
--- | Enable/disable periodic notifications
-enableNtfCron :: AgentErrorMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
-enableNtfCron c = withAgentEnv c .: enableNtfCron' c
-
-checkNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-checkNtfToken c = withAgentEnv c . checkNtfToken' c
-
-deleteNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m ()
-deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
-
 withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
 withAgentEnv c = (`runReaderT` agentEnv c)
 
@@ -194,8 +150,8 @@ withAgentEnv c = (`runReaderT` agentEnv c)
 -- withAgentClient c = withAgentLock c . withAgentEnv c
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => InitialAgentServers -> m AgentClient
-getAgentClient initServers = ask >>= atomically . newAgentClient initServers
+getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient
+getAgentClient = ask >>= atomically . newAgentClient
 
 logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
 logConnection c connected =
@@ -216,18 +172,22 @@ client c@AgentClient {rcvQ, subQ} = forever $ do
 
 withStore ::
   AgentMonad m =>
-  (forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
+  (forall m'. (MonadUnliftIO m', MonadError StoreError m') => PostgresStore -> m' a) ->
   m a
 withStore action = do
   st <- asks store
   runExceptT (action st `E.catch` handleInternal) >>= \case
     Right c -> return c
-    Left e -> throwError $ storeError e
+    Left e -> do
+      liftIO $ print e
+      throwError $ storeError e
   where
     -- TODO when parsing exception happens in store, the agent hangs;
     -- changing SQLError to SomeException does not help
-    handleInternal :: (MonadError StoreError m') => SQLError -> m' a
-    handleInternal e = throwError . SEInternal $ bshow e
+    handleInternal :: (MonadUnliftIO m', MonadError StoreError m') => SQLError -> m' a
+    handleInternal e = do
+      liftIO $ print e
+      throwError . SEInternal $ bshow e
     storeError :: StoreError -> AgentErrorType
     storeError = \case
       SEConnNotFound -> CONN NOT_FOUND
@@ -253,7 +213,7 @@ processCommand c (connId, cmd) = case cmd of
 
 newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c)
 newConn c connId cMode = do
-  srv <- getSMPServer c
+  srv <- getSMPServer
   (rq, qUri) <- newRcvQueue c srv
   g <- asks idsDrg
   let cData = ConnData {connId}
@@ -278,21 +238,19 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
       (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
       (_, rcDHRs) <- liftIO C.generateKeyPair'
       let rc = CR.initSndRatchet rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
-      sq <- newSndQueue qInfo
+      (sq, smpConf) <- newSndQueue qInfo cInfo
       g <- asks idsDrg
       let cData = ConnData {connId}
       connId' <- withStore $ \st -> do
+        liftIO $ print "before: createSndConn st g cData sq"
         connId' <- createSndConn st g cData sq
+        liftIO $ print "before: createRatchet st connId' rc"
         createRatchet st connId' rc
+        liftIO $ print "after: createRatchet st connId' rc"
         pure connId'
-      tryError (confirmQueue c connId' sq cInfo $ Just e2eSndParams) >>= \case
-        Right _ -> do
-          void $ enqueueMessage c connId' sq HELLO
-          pure connId'
-        Left e -> do
-          -- TODO recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
-          withStore (`deleteConn` connId')
-          throwError e
+      confirmQueue c connId' sq smpConf $ Just e2eSndParams
+      void $ enqueueMessage c connId' sq HELLO
+      pure connId'
     _ -> throwError $ AGENT A_VERSION
 joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo =
   case ( qUri `compatibleVersion` SMP.smpClientVRange,
@@ -307,7 +265,7 @@ joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInf
 
 createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
 createReplyQueue c connId sq = do
-  srv <- getSMPServer c
+  srv <- getSMPServer
   (rq, qUri) <- newRcvQueue c srv
   -- TODO reply queue version should be the same as send queue, ignoring it in v1
   let qInfo = toVersionT qUri SMP.smpClientVersion
@@ -354,6 +312,16 @@ subscribeConnection' c connId =
     SomeConn _ (DuplexConnection _ rq sq) -> do
       resumeMsgDelivery c connId sq
       subscribeQueue c rq connId
+      case status (sq :: SndQueue) of
+        Confirmed -> do
+          -- TODO if there is no confirmation saved, just update the status without securing the queue
+          AcceptedConfirmation {senderConf = SMPConfirmation {senderKey}} <-
+            withStore (`getAcceptedConfirmation` connId)
+          secureQueue c rq senderKey
+          withStore $ \st -> setRcvQueueStatus st rq Secured
+        Secured -> pure ()
+        Active -> pure ()
+        _ -> throwError $ INTERNAL "unexpected queue status"
     SomeConn _ (SndConnection _ sq) -> do
       resumeMsgDelivery c connId sq
       case status (sq :: SndQueue) of
@@ -363,12 +331,6 @@ subscribeConnection' c connId =
     SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId
     SomeConn _ (ContactConnection _ rq) -> subscribeQueue c rq connId
 
-resubscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
-resubscribeConnection' c connId =
-  unlessM
-    (atomically $ hasActiveSubscription c connId)
-    (subscribeConnection' c connId)
-
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId
 sendMessage' c connId msg =
@@ -392,12 +354,12 @@ enqueueMessage c connId sq aMessage = do
       internalTs <- liftIO getCurrentTime
       (internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
-          agentMsg = AgentMessage privHeader aMessage
-          agentMsgStr = smpEncode agentMsg
-          internalHash = C.sha256Hash agentMsgStr
-      encAgentMessage <- agentRatchetEncrypt connId agentMsgStr e2eEncUserMsgLength
+          agentMessage = smpEncode $ AgentMessage privHeader aMessage
+          internalHash = C.sha256Hash agentMessage
+
+      encAgentMessage <- agentRatchetEncrypt connId agentMessage e2eEncUserMsgLength
       let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = smpAgentVersion, encAgentMessage}
-          msgType = agentMessageType agentMsg
+          msgType = aMessageType aMessage
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, internalHash, prevMsgHash}
       withStore $ \st -> createSndMsg st connId msgData
       pure internalId
@@ -407,13 +369,18 @@ resumeMsgDelivery c connId sq@SndQueue {server, sndId} = do
   let qKey = (connId, server, sndId)
   unlessM (queueDelivering qKey) $
     async (runSmpQueueMsgDelivery c connId sq)
-      >>= \a -> atomically (TM.insert qKey a $ smpQueueMsgDeliveries c)
+      >>= atomically . modifyTVar (smpQueueMsgDeliveries c) . M.insert qKey
   unlessM connQueued $
     withStore (`getPendingMsgs` connId)
       >>= queuePendingMsgs c connId sq
   where
-    queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
-    connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connMsgsQueued c)
+    queueDelivering qKey = isJust . M.lookup qKey <$> readTVarIO (smpQueueMsgDeliveries c)
+    connQueued =
+      atomically $
+        isJust
+          <$> stateTVar
+            (connMsgsQueued c)
+            (\m -> (M.lookup connId m, M.insert connId True m))
 
 queuePendingMsgs :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> [InternalId] -> m ()
 queuePendingMsgs c connId sq msgIds = atomically $ do
@@ -423,11 +390,11 @@ queuePendingMsgs c connId sq msgIds = atomically $ do
 getPendingMsgQ :: AgentClient -> ConnId -> SndQueue -> STM (TQueue InternalId)
 getPendingMsgQ c connId SndQueue {server, sndId} = do
   let qKey = (connId, server, sndId)
-  maybe (newMsgQueue qKey) pure =<< TM.lookup qKey (smpQueueMsgQueues c)
+  maybe (newMsgQueue qKey) pure . M.lookup qKey =<< readTVar (smpQueueMsgQueues c)
   where
     newMsgQueue qKey = do
       mq <- newTQueue
-      TM.insert qKey mq $ smpQueueMsgQueues c
+      modifyTVar (smpQueueMsgQueues c) $ M.insert qKey mq
       pure mq
 
 runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
@@ -442,38 +409,30 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
         notify $ MERR mId (INTERNAL $ show e)
       Right (rq_, (msgType, msgBody, internalTs)) ->
         withRetryInterval ri $ \loop ->
-          tryError (send msgType c sq msgBody) >>= \case
+          tryError (sendAgentMessage c sq msgBody) >>= \case
             Left e -> do
-              let err = if msgType == AM_CONN_INFO then ERR e else MERR mId e
               case e of
-                SMP SMP.QUOTA -> case msgType of
-                  AM_CONN_INFO -> connError msgId NOT_AVAILABLE
-                  _ -> loop
+                SMP SMP.QUOTA -> loop
                 SMP SMP.AUTH -> case msgType of
-                  AM_CONN_INFO -> connError msgId NOT_AVAILABLE
-                  AM_HELLO_ -> do
+                  HELLO_ -> do
                     helloTimeout <- asks $ helloTimeout . config
                     currentTime <- liftIO getCurrentTime
                     if diffUTCTime currentTime internalTs > helloTimeout
                       then case rq_ of
                         -- party initiating connection
-                        Just _ -> connError msgId NOT_AVAILABLE
+                        Just _ -> notifyDel msgId . ERR $ CONN NOT_AVAILABLE
                         -- party joining connection
-                        _ -> connError msgId NOT_ACCEPTED
+                        _ -> notifyDel msgId . ERR $ CONN NOT_ACCEPTED
                       else loop
-                  AM_REPLY_ -> notifyDel msgId $ ERR e
-                  AM_A_MSG_ -> notifyDel msgId $ MERR mId e
-                SMP (SMP.CMD _) -> notifyDel msgId err
-                SMP SMP.LARGE_MSG -> notifyDel msgId err
-                SMP {} -> notify err >> loop
+                  REPLY_ -> notifyDel msgId $ ERR e
+                  A_MSG_ -> notifyDel msgId $ MERR mId e
+                SMP (SMP.CMD _) -> notifyDel msgId $ MERR mId e
+                SMP SMP.LARGE_MSG -> notifyDel msgId $ MERR mId e
+                SMP {} -> notify (MERR mId e) >> loop
                 _ -> loop
             Right () -> do
               case msgType of
-                AM_CONN_INFO -> do
-                  withStore $ \st -> setSndQueueStatus st sq Confirmed
-                  when (isJust rq_) $ withStore (`removeConfirmations` connId)
-                  void $ enqueueMessage c connId sq HELLO
-                AM_HELLO_ -> do
+                HELLO_ -> do
                   withStore $ \st -> setSndQueueStatus st sq Active
                   case rq_ of
                     -- party initiating connection
@@ -482,20 +441,16 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
                       notify CON
                     -- party joining connection
                     _ -> createReplyQueue c connId sq
-                AM_A_MSG_ -> notify $ SENT mId
+                A_MSG_ -> notify $ SENT mId
                 _ -> pure ()
               delMsg msgId
   where
-    send = \case
-      AM_CONN_INFO -> sendConfirmation
-      _ -> sendAgentMessage
     delMsg :: InternalId -> m ()
     delMsg msgId = withStore $ \st -> deleteMsg st connId msgId
     notify :: ACommand 'Agent -> m ()
     notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
     notifyDel :: InternalId -> ACommand 'Agent -> m ()
     notifyDel msgId cmd = notify cmd >> delMsg msgId
-    connError msgId = notifyDel msgId . ERR . CONN
 
 ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
 ackMessage' c connId msgId = do
@@ -531,135 +486,17 @@ deleteConnection' c connId =
     delete :: RcvQueue -> m ()
     delete rq = do
       deleteQueue c rq
-      atomically $ removeSubscription c connId
+      removeSubscription c connId
       withStore (`deleteConn` connId)
 
--- | Change servers to be used for creating new queues, in Reader monad
-setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
-setSMPServers' c servers = do
-  atomically $ writeTVar (smpServers c) servers
-
-registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-registerNtfToken' c deviceToken =
-  withStore (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId, ntfTknStatus, ntfTknAction}, prevTokens) -> do
-      mapM_ (deleteToken_ c) prevTokens
-      case (ntfTokenId, ntfTknAction) of
-        (Nothing, Just NTARegister) -> registerToken tkn $> NTRegistered
-        -- TODO minimal time before repeat registration
-        (Just _, Nothing) -> when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
-        (Just tknId, Just (NTAVerify code)) ->
-          t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
-        (Just tknId, Just (NTACron interval)) ->
-          t tkn (cronSuccess interval) $ agentNtfEnableCron c tknId tkn interval
-        (Just _tknId, Just NTACheck) -> pure ntfTknStatus -- TODO
-        -- agentNtfCheckToken c tknId tkn >>= \case
-        (Just tknId, Just NTADelete) -> do
-          agentNtfDeleteToken c tknId tkn
-          withStore $ \st -> removeNtfToken st tkn $> NTExpired
-        _ -> pure ntfTknStatus
-    _ ->
-      getNtfServer c >>= \case
-        Just ntfServer ->
-          asks (cmdSignAlg . config) >>= \case
-            C.SignAlg a -> do
-              tknKeys <- liftIO $ C.generateSignatureKeyPair a
-              dhKeys <- liftIO C.generateKeyPair'
-              let tkn = newNtfToken deviceToken ntfServer tknKeys dhKeys
-              withStore $ \st -> createNtfToken st tkn
-              registerToken tkn
-              pure NTRegistered
-        _ -> throwError $ CMD PROHIBITED
-  where
-    t tkn = withToken c tkn Nothing
-    registerToken :: NtfToken -> m ()
-    registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
-      (tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
-      let dhSecret = C.dh' srvPubDhKey privDhKey
-      withStore $ \st -> updateNtfTokenRegistration st tkn tknId dhSecret
-
--- TODO decrypt verification code
-verifyNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
-verifyNtfToken' c deviceToken code nonce =
-  withStore (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret}, _) -> do
-      code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
-      void . withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
-        agentNtfVerifyToken c tknId tkn code'
-    _ -> throwError $ CMD PROHIBITED
-
-enableNtfCron' :: AgentMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
-enableNtfCron' c deviceToken interval = do
-  when (interval < 20) . throwError $ CMD PROHIBITED
-  withStore (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive}, _) ->
-      void . withToken c tkn (Just (NTActive, NTACron interval)) (cronSuccess interval) $
-        agentNtfEnableCron c tknId tkn interval
-    _ -> throwError $ CMD PROHIBITED
-
-cronSuccess :: Word16 -> (NtfTknStatus, Maybe NtfTknAction)
-cronSuccess interval
-  | interval == 0 = (NTActive, Just NTACheck)
-  | otherwise = (NTActive, Just $ NTACron interval)
-
-checkNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-checkNtfToken' c deviceToken =
-  withStore (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId}, _) -> agentNtfCheckToken c tknId tkn
-    _ -> throwError $ CMD PROHIBITED
-
-deleteNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m ()
-deleteNtfToken' c deviceToken =
-  withStore (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn, _) -> deleteToken_ c tkn
-    _ -> throwError $ CMD PROHIBITED
-
-deleteToken_ :: AgentMonad m => AgentClient -> NtfToken -> m ()
-deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
-  forM_ ntfTokenId $ \tknId -> do
-    withStore $ \st -> updateNtfToken st tkn ntfTknStatus (Just NTADelete)
-    agentNtfDeleteToken c tknId tkn `catchError` \case
-      NTF AUTH -> pure ()
-      e -> throwError e
-  withStore $ \st -> removeNtfToken st tkn
-
-withToken :: AgentMonad m => AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> m a -> m NtfTknStatus
-withToken c tkn@NtfToken {deviceToken} from_ (toStatus, toAction_) f = do
-  forM_ from_ $ \(status, action) -> withStore $ \st -> updateNtfToken st tkn status (Just action)
-  tryError f >>= \case
-    Right _ -> do
-      withStore $ \st -> updateNtfToken st tkn toStatus toAction_
-      pure toStatus
-    Left e@(NTF AUTH) -> do
-      withStore $ \st -> removeNtfToken st tkn
-      void $ registerNtfToken' c deviceToken
-      throwError e
-    Left e -> throwError e
-
-setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
-setNtfServers' c servers = do
-  atomically $ writeTVar (ntfServers c) servers
-
-getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
-getSMPServer c = do
-  smpServers <- readTVarIO $ smpServers c
-  case smpServers of
+getSMPServer :: AgentMonad m => m SMPServer
+getSMPServer =
+  asks (smpServers . config) >>= \case
     srv :| [] -> pure srv
     servers -> do
       gen <- asks randomServer
-      atomically . stateTVar gen $
-        first (servers L.!!) . randomR (0, L.length servers - 1)
-
-getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
-getNtfServer c = do
-  ntfServers <- readTVarIO $ ntfServers c
-  case ntfServers of
-    [] -> pure Nothing
-    [srv] -> pure $ Just srv
-    servers -> do
-      gen <- asks randomServer
-      atomically . stateTVar gen $
-        first (Just . (servers !!)) . randomR (0, length servers - 1)
+      i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1)
+      pure $ servers L.!! i
 
 subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
 subscriber c@AgentClient {msgQ} = forever $ do
@@ -668,8 +505,8 @@ subscriber c@AgentClient {msgQ} = forever $ do
     Left e -> liftIO $ print e
     Right _ -> return ()
 
-processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
-processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd) = do
+processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SMPServerTransmission -> m ()
+processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
   withStore (\st -> getRcvConn st srv rId) >>= \case
     SomeConn SCDuplex (DuplexConnection cData rq _) -> processSMP SCDuplex cData rq
     SomeConn SCRcv (RcvConnection cData rq) -> processSMP SCRcv cData rq
@@ -699,9 +536,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
                 (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
                   agentMsgBody <- agentRatchetDecrypt connId encAgentMsg
                   parseMessage agentMsgBody >>= \case
-                    agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
-                      let msgType = agentMessageType agentMsg
-                      (msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) agentMsgBody msgType
+                    AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage -> do
+                      (msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) agentMsgBody aMessage
                       case aMessage of
                         HELLO -> helloMsg >> ack >> withStore (\st -> deleteMsg st connId msgId)
                         REPLY cReq -> replyMsg cReq >> ack >> withStore (\st -> deleteMsg st connId msgId)
@@ -710,19 +546,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
                     _ -> prohibited >> ack
                 _ -> prohibited >> ack
             _ -> prohibited >> ack
-        SMP.END ->
-          atomically (TM.lookup srv smpClients $>>= tryReadTMVar >>= processEND)
-            >>= logServer "<--" c srv rId
-          where
-            processEND = \case
-              Just (Right clnt)
-                | sessId == sessionId clnt -> do
-                  removeSubscription c connId
-                  writeTBQueue subQ ("", connId, END)
-                  pure "END"
-                | otherwise -> ignored
-              _ -> ignored
-            ignored = pure "END from disconnected client - ignored"
+        SMP.END -> do
+          removeSubscription c connId
+          logServer "<--" c srv rId "END"
+          notify END
         _ -> do
           logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
           notify . ERR $ BROKER UNEXPECTED
@@ -800,13 +627,18 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
               case qInfo `proveCompatible` SMP.smpClientVRange of
                 Nothing -> notify . ERR $ AGENT A_VERSION
                 Just qInfo' -> do
-                  sq <- newSndQueue qInfo'
+                  (sq, smpConf) <- newSndQueue qInfo' ownConnInfo
+                  liftIO $ print "before: upgradeRcvConnToDuplex st connId sq"
                   withStore $ \st -> upgradeRcvConnToDuplex st connId sq
-                  enqueueConfirmation c connId sq ownConnInfo Nothing
+                  confirmQueue c connId sq smpConf Nothing
+                  liftIO $ print "before: `removeConfirmations` connId"
+                  withStore (`removeConfirmations` connId)
+                  liftIO $ print "after: `removeConfirmations` connId"
+                  void $ enqueueMessage c connId sq HELLO
             _ -> prohibited
 
-        agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> AgentMessageType -> m (InternalId, MsgMeta)
-        agentClientMsg externalPrevSndHash sndMsgId broker msgBody msgType = do
+        agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> AMessage -> m (InternalId, MsgMeta)
+        agentClientMsg externalPrevSndHash sndMsgId broker msgBody aMessage = do
           logServer "<--" c srv rId "MSG <MSG>"
           let internalHash = C.sha256Hash msgBody
           internalTs <- liftIO getCurrentTime
@@ -814,6 +646,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
           let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash externalPrevSndHash
               recipient = (unId internalId, internalTs)
               msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
+              msgType = aMessageType aMessage
               rcvMsg = RcvMsgData {msgMeta, msgType, msgBody, internalRcvId, internalHash, externalPrevSndHash}
           withStore $ \st -> createRcvMsg st connId rcvMsg
           pure (internalId, msgMeta)
@@ -838,9 +671,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
           | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
           | otherwise = MsgError MsgDuplicate -- this case is not possible
 
-confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
-confirmQueue c connId sq connInfo e2eEncryption = do
-  _ <- withStore (`updateSndIds` connId)
+confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> SMPConfirmation -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
+confirmQueue c connId sq SMPConfirmation {senderKey, e2ePubKey, connInfo} e2eEncryption = do
   msg <- mkConfirmation
   sendConfirmation c sq msg
   withStore $ \st -> setSndQueueStatus st sq Confirmed
@@ -848,27 +680,9 @@ confirmQueue c connId sq connInfo e2eEncryption = do
     mkConfirmation :: m MsgBody
     mkConfirmation = do
       encConnInfo <- agentRatchetEncrypt connId (smpEncode $ AgentConnInfo connInfo) e2eEncConnInfoLength
-      pure . smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
-
-enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
-enqueueConfirmation c connId sq connInfo e2eEncryption = do
-  resumeMsgDelivery c connId sq
-  msgId <- storeConfirmation
-  queuePendingMsgs c connId sq [msgId]
-  where
-    storeConfirmation :: m InternalId
-    storeConfirmation = do
-      internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
-      let agentMsg = AgentConnInfo connInfo
-          agentMsgStr = smpEncode agentMsg
-          internalHash = C.sha256Hash agentMsgStr
-      encConnInfo <- agentRatchetEncrypt connId agentMsgStr e2eEncConnInfoLength
-      let msgBody = smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
-          msgType = agentMessageType agentMsg
-          msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, internalHash, prevMsgHash}
-      withStore $ \st -> createSndMsg st connId msgData
-      pure internalId
+      let agentEnvelope = AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
+      agentCbEncrypt sq (Just e2ePubKey) . smpEncode $
+        SMP.ClientMessage (SMP.PHConfirmation senderKey) $ smpEncode agentEnvelope
 
 -- encoded AgentMessage -> encoded EncAgentMessage
 agentRatchetEncrypt :: AgentMonad m => ConnId -> ByteString -> Int -> m ByteString
@@ -890,27 +704,27 @@ agentRatchetDecrypt connId encAgentMsg = do
 notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
 notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
 
-newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> m SndQueue
-newSndQueue qInfo =
+newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> ConnInfo -> m (SndQueue, SMPConfirmation)
+newSndQueue qInfo cInfo =
   asks (cmdSignAlg . config) >>= \case
-    C.SignAlg a -> newSndQueue_ a qInfo
+    C.SignAlg a -> newSndQueue_ a qInfo cInfo
 
 newSndQueue_ ::
   (C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m) =>
   C.SAlgorithm a ->
   Compatible SMPQueueInfo ->
-  m SndQueue
-newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) = do
+  ConnInfo ->
+  m (SndQueue, SMPConfirmation)
+newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) cInfo = do
   -- this function assumes clientVersion is compatible - it was tested before
-  (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+  (senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
   (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
-  pure
-    SndQueue
-      { server = smpServer,
-        sndId = senderId,
-        sndPublicKey = Just sndPublicKey,
-        sndPrivateKey,
-        e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
-        e2ePubKey = Just e2ePubKey,
-        status = New
-      }
+  let sndQueue =
+        SndQueue
+          { server = smpServer,
+            sndId = senderId,
+            sndPrivateKey,
+            e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
+            status = New
+          }
+  pure (sndQueue, SMPConfirmation senderKey e2ePubKey cInfo)

src/Simplex/Messaging/Agent/Client.hs

@@ -1,15 +1,15 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
@@ -25,11 +25,6 @@ module Simplex.Messaging.Agent.Client
     RetryInterval (..),
     secureQueue,
     sendAgentMessage,
-    agentNtfRegisterToken,
-    agentNtfVerifyToken,
-    agentNtfCheckToken,
-    agentNtfDeleteToken,
-    agentNtfEnableCron,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -38,13 +33,11 @@ module Simplex.Messaging.Agent.Client
     deleteQueue,
     logServer,
     removeSubscription,
-    hasActiveSubscription,
-    agentDbPath,
   )
 where
 
 import Control.Concurrent (forkIO)
-import Control.Concurrent.Async (Async, uninterruptibleCancel)
+import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
 import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
@@ -54,286 +47,177 @@ import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes)
+import Data.Maybe (isNothing)
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text.Encoding
-import Data.Word (Word16)
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..))
 import Simplex.Messaging.Client
-import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Client
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
+import Simplex.Messaging.Protocol (QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (bshow, catchAll_, ifM, liftEitherError, liftError, tryError, unlessM, whenM)
+import Simplex.Messaging.Util (bshow, liftEitherError, liftError, liftIOEither, tryError)
 import Simplex.Messaging.Version
-import System.Timeout (timeout)
-import UnliftIO (async, pooledForConcurrentlyN)
+import UnliftIO.Exception (Exception, IOException)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type ClientVar msg = TMVar (Either AgentErrorType (ProtocolClient msg))
-
 type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
 
-type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
-
 data AgentClient = AgentClient
-  { active :: TVar Bool,
-    rcvQ :: TBQueue (ATransmission 'Client),
+  { rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
-    msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    smpServers :: TVar (NonEmpty SMPServer),
-    ntfServers :: TVar [NtfServer],
-    smpClients :: TMap SMPServer SMPClientVar,
-    ntfClients :: TMap NtfServer NtfClientVar,
-    subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    subscrConns :: TMap ConnId SMPServer,
-    connMsgsQueued :: TMap ConnId Bool,
-    smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
-    smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
+    msgQ :: TBQueue SMPServerTransmission,
+    smpClients :: TVar (Map SMPServer SMPClientVar),
+    subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
+    subscrConns :: TVar (Map ConnId SMPServer),
+    connMsgsQueued :: TVar (Map ConnId Bool),
+    smpQueueMsgQueues :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId)),
+    smpQueueMsgDeliveries :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (Async ())),
     reconnections :: TVar [Async ()],
-    asyncClients :: TVar [Async ()],
     clientId :: Int,
     agentEnv :: Env,
     smpSubscriber :: Async (),
     lock :: TMVar ()
   }
 
-newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
+newAgentClient :: Env -> STM AgentClient
+newAgentClient agentEnv = do
   let qSize = tbqSize $ config agentEnv
-  active <- newTVar True
   rcvQ <- newTBQueue qSize
   subQ <- newTBQueue qSize
   msgQ <- newTBQueue qSize
-  smpServers <- newTVar smp
-  ntfServers <- newTVar ntf
-  smpClients <- TM.empty
-  ntfClients <- TM.empty
-  subscrSrvrs <- TM.empty
-  pendingSubscrSrvrs <- TM.empty
-  subscrConns <- TM.empty
-  connMsgsQueued <- TM.empty
-  smpQueueMsgQueues <- TM.empty
-  smpQueueMsgDeliveries <- TM.empty
+  smpClients <- newTVar M.empty
+  subscrSrvrs <- newTVar M.empty
+  subscrConns <- newTVar M.empty
+  connMsgsQueued <- newTVar M.empty
+  smpQueueMsgQueues <- newTVar M.empty
+  smpQueueMsgDeliveries <- newTVar M.empty
   reconnections <- newTVar []
-  asyncClients <- newTVar []
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
   lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, ntfServers, smpClients, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
-
-agentDbPath :: AgentClient -> FilePath
-agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
+  return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock}
 
 -- | Agent monad with MonadReader Env and MonadError AgentErrorType
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
-class ProtocolServerClient msg where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
-  protocolError :: ErrorType -> AgentErrorType
+newtype InternalException e = InternalException {unInternalException :: e}
+  deriving (Eq, Show)
 
-instance ProtocolServerClient BrokerMsg where
-  getProtocolServerClient = getSMPServerClient
-  protocolError = SMP
+instance Exception e => Exception (InternalException e)
 
-instance ProtocolServerClient NtfResponse where
-  getProtocolServerClient = getNtfServerClient
-  protocolError = NTF
+instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
+  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
+  withRunInIO exceptToIO =
+    withExceptT unInternalException . ExceptT . E.try $
+      withRunInIO $ \run ->
+        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
 
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
-getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
-  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
-  atomically (getClientVar srv smpClients)
-    >>= either
-      (newProtocolClient c srv smpClients connectClient reconnectClient)
-      (waitForProtocolClient smpCfg)
+getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
+  atomically getClientVar >>= either newSMPClient waitForSMPClient
   where
+    getClientVar :: STM (Either SMPClientVar SMPClientVar)
+    getClientVar = maybe (Left <$> newClientVar) (pure . Right) . M.lookup srv =<< readTVar smpClients
+
+    newClientVar :: STM SMPClientVar
+    newClientVar = do
+      smpVar <- newEmptyTMVar
+      modifyTVar smpClients $ M.insert srv smpVar
+      pure smpVar
+
+    waitForSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
+    waitForSMPClient = liftIOEither . atomically . readTMVar
+
+    newSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
+    newSMPClient smpVar =
+      tryError connectClient >>= \r -> case r of
+        Right smp -> do
+          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
+          atomically $ putTMVar smpVar r
+          pure smp
+        Left e -> do
+          atomically $ do
+            putTMVar smpVar r
+            modifyTVar smpClients $ M.delete srv
+          throwError e
+
     connectClient :: m SMPClient
     connectClient = do
       cfg <- asks $ smpCfg . config
       u <- askUnliftIO
-      liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
+      liftEitherError smpClientError (getSMPClient srv cfg msgQ $ clientDisconnected u)
+        `E.catch` internalError
+      where
+        internalError :: IOException -> m SMPClient
+        internalError = throwError . INTERNAL . show
 
     clientDisconnected :: UnliftIO m -> IO ()
     clientDisconnected u = do
-      removeClientAndSubs >>= (`forM_` serverDown u)
+      removeClientSubs >>= (`forM_` serverDown u)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
-      TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
+    removeClientSubs :: IO (Maybe (Map ConnId RcvQueue))
+    removeClientSubs = atomically $ do
+      modifyTVar smpClients $ M.delete srv
+      cs <- M.lookup srv <$> readTVar (subscrSrvrs c)
+      modifyTVar (subscrSrvrs c) $ M.delete srv
+      modifyTVar (subscrConns c) $ maybe id (deleteKeys . M.keysSet) cs
+      return cs
       where
-        updateSubs cVar = do
-          cs <- readTVar cVar
-          modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
-          addPendingSubs cVar cs
-          pure cs
-
-        addPendingSubs cVar cs = do
-          let ps = pendingSubscrSrvrs c
-          TM.lookup srv ps >>= \case
-            Just v -> TM.union cs v
-            _ -> TM.insert srv cVar ps
+        deleteKeys :: Ord k => Set k -> Map k a -> Map k a
+        deleteKeys ks m = S.foldr' M.delete m ks
 
     serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
-    serverDown u cs = unless (M.null cs) $
-      whenM (readTVarIO active) $ do
-        let conns = M.keys cs
-        unless (null conns) . notifySub "" $ DOWN srv conns
-        unliftIO u reconnectServer
+    serverDown u cs = unless (M.null cs) $ do
+      mapM_ (notifySub DOWN) $ M.keysSet cs
+      a <- async . unliftIO u $ tryReconnectClient cs
+      atomically $ modifyTVar (reconnections c) (a :)
 
-    reconnectServer :: m ()
-    reconnectServer = do
-      a <- async tryReconnectClient
-      atomically $ modifyTVar' (reconnections c) (a :)
-
-    tryReconnectClient :: m ()
-    tryReconnectClient = do
+    tryReconnectClient :: Map ConnId RcvQueue -> m ()
+    tryReconnectClient cs = do
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop ->
-        reconnectClient `catchError` const loop
+        reconnectClient cs `catchError` const loop
 
-    reconnectClient :: m ()
-    reconnectClient = do
-      n <- asks $ resubscriptionConcurrency . config
-      withAgentLock c . withClient c srv $ \smp -> do
-        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSubscrSrvrs c)
-        conns <- pooledForConcurrentlyN n (maybe [] M.toList cs) $ \sub@(connId, _) ->
-          ifM
-            (atomically $ hasActiveSubscription c connId)
-            (pure $ Just connId)
-            (subscribe_ smp sub `catchError` handleError connId)
-        liftIO . unless (null conns) . notifySub "" . UP srv $ catMaybes conns
-      where
-        subscribe_ :: SMPClient -> (ConnId, RcvQueue) -> ExceptT ProtocolClientError IO (Maybe ConnId)
-        subscribe_ smp (connId, rq@RcvQueue {rcvPrivateKey, rcvId}) = do
-          subscribeSMPQueue smp rcvPrivateKey rcvId
-          addSubscription c rq connId
-          pure $ Just connId
+    reconnectClient :: Map ConnId RcvQueue -> m ()
+    reconnectClient cs = do
+      withAgentLock c . withSMP c srv $ \smp -> do
+        subs <- readTVarIO $ subscrConns c
+        forM_ (M.toList cs) $ \(connId, rq@RcvQueue {rcvPrivateKey, rcvId}) ->
+          when (isNothing $ M.lookup connId subs) $ do
+            subscribeSMPQueue smp rcvPrivateKey rcvId
+              `catchError` \case
+                SMPServerError e -> liftIO $ notifySub (ERR $ SMP e) connId
+                e -> throwError e
+            addSubscription c rq connId
+            liftIO $ notifySub UP connId
 
-        handleError :: ConnId -> ProtocolClientError -> ExceptT ProtocolClientError IO (Maybe ConnId)
-        handleError connId = \case
-          e@PCEResponseTimeout -> throwError e
-          e@PCENetworkError -> throwError e
-          e -> do
-            liftIO . notifySub connId . ERR $ protocolClientError SMP e
-            atomically $ removePendingSubscription c srv connId
-            pure Nothing
+    notifySub :: ACommand 'Agent -> ConnId -> IO ()
+    notifySub cmd connId = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
 
-    notifySub :: ConnId -> ACommand 'Agent -> IO ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
-
-getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient
-getNtfServerClient c@AgentClient {active, ntfClients} srv = do
-  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
-  atomically (getClientVar srv ntfClients)
-    >>= either
-      (newProtocolClient c srv ntfClients connectClient $ pure ())
-      (waitForProtocolClient ntfCfg)
-  where
-    connectClient :: m NtfClient
-    connectClient = do
-      cfg <- asks $ ntfCfg . config
-      liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
-
-    clientDisconnected :: IO ()
-    clientDisconnected = do
-      atomically $ TM.delete srv ntfClients
-      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
-
-getClientVar :: forall a. ProtocolServer -> TMap ProtocolServer (TMVar a) -> STM (Either (TMVar a) (TMVar a))
-getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
-  where
-    newClientVar :: STM (TMVar a)
-    newClientVar = do
-      var <- newEmptyTMVar
-      TM.insert srv var clients
-      pure var
-
-waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
-waitForProtocolClient clientConfig clientVar = do
-  ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
-  client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
-  liftEither $ case client_ of
-    Just (Right smpClient) -> Right smpClient
-    Just (Left e) -> Left e
-    Nothing -> Left $ BROKER TIMEOUT
-
-newProtocolClient ::
-  forall msg m.
-  AgentMonad m =>
-  AgentClient ->
-  ProtocolServer ->
-  TMap ProtocolServer (ClientVar msg) ->
-  m (ProtocolClient msg) ->
-  m () ->
-  ClientVar msg ->
-  m (ProtocolClient msg)
-newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
-  where
-    tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
-    tryConnectClient successAction retryAction =
-      tryError connectClient >>= \r -> case r of
-        Right client -> do
-          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-          atomically $ putTMVar clientVar r
-          successAction client
-        Left e -> do
-          if e == BROKER NETWORK || e == BROKER TIMEOUT
-            then retryAction
-            else atomically $ do
-              putTMVar clientVar (Left e)
-              TM.delete srv clients
-          throwError e
-    tryConnectAsync :: m ()
-    tryConnectAsync = do
-      a <- async connectAsync
-      atomically $ modifyTVar' (asyncClients c) (a :)
-    connectAsync :: m ()
-    connectAsync = do
-      ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
-
-closeAgentClient :: MonadIO m => AgentClient -> m ()
+closeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
-  atomically $ writeTVar (active c) False
-  closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
-  closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
+  closeSMPServerClients c
   cancelActions $ reconnections c
-  cancelActions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
-  clear subscrSrvrs
-  clear pendingSubscrSrvrs
-  clear subscrConns
-  clear connMsgsQueued
-  clear smpQueueMsgQueues
-  where
-    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
-    clear sel = atomically $ writeTVar (sel c) M.empty
 
-closeProtocolServerClients :: Int -> TMap ProtocolServer (ClientVar msg) -> IO ()
-closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+closeSMPServerClients :: AgentClient -> IO ()
+closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
   where
-    closeClient cVar =
-      tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
-        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
+    closeClient smpVar =
+      atomically (readTMVar smpVar) >>= \case
+        Right smp -> closeSMPClient smp `E.catch` \(_ :: E.SomeException) -> pure ()
         _ -> pure ()
 
-cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel >> atomically (writeTVar as mempty)
+cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
+cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
 
 withAgentLock :: MonadUnliftIO m => AgentClient -> m a -> m a
 withAgentLock AgentClient {lock} =
@@ -341,40 +225,40 @@ withAgentLock AgentClient {lock} =
     (void . atomically $ takeTMVar lock)
     (atomically $ putTMVar lock ())
 
-withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> m a) -> m a
-withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
+withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
+withSMP_ c srv action =
+  (getSMPServerClient c srv >>= action) `catchError` logServerError
   where
     logServerError :: AgentErrorType -> m a
     logServerError e = do
       logServer "<--" c srv "" $ bshow e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
-withLogClient_ c srv qId cmdStr action = do
+withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
+withLogSMP_ c srv qId cmdStr action = do
   logServer "-->" c srv qId cmdStr
-  res <- withClient_ c srv action
+  res <- withSMP_ c srv action
   logServer "<--" c srv qId "OK"
   return res
 
-withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withClient c srv action = withClient_ c srv $ liftClient (protocolError @msg) . action
+withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
+withSMP c srv action = withSMP_ c srv $ liftSMP . action
 
-withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (protocolError @msg) . action
+withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
+withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action
 
-liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
-liftClient = liftError . protocolClientError
+liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
+liftSMP = liftError smpClientError
 
-protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
-protocolClientError protocolError_ = \case
-  PCEProtocolError e -> protocolError_ e
-  PCEResponseError e -> BROKER $ RESPONSE e
-  PCEUnexpectedResponse -> BROKER UNEXPECTED
-  PCEResponseTimeout -> BROKER TIMEOUT
-  PCENetworkError -> BROKER NETWORK
-  PCETransportError e -> BROKER $ TRANSPORT e
-  e@PCESignatureError {} -> INTERNAL $ show e
-  e@PCEIOError {} -> INTERNAL $ show e
+smpClientError :: SMPClientError -> AgentErrorType
+smpClientError = \case
+  SMPServerError e -> SMP e
+  SMPResponseError e -> BROKER $ RESPONSE e
+  SMPUnexpectedResponse -> BROKER UNEXPECTED
+  SMPResponseTimeout -> BROKER TIMEOUT
+  SMPNetworkError -> BROKER NETWORK
+  SMPTransportError e -> BROKER $ TRANSPORT e
+  e -> INTERNAL $ show e
 
 newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
 newRcvQueue c srv =
@@ -393,7 +277,7 @@ newRcvQueue_ a c srv = do
   (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
   QIK {rcvId, sndId, rcvPublicDhKey} <-
-    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+    withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
@@ -410,69 +294,54 @@ newRcvQueue_ a c srv = do
 
 subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
 subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
-  atomically $ addPendingSubscription c rq connId
-  withLogClient c server rcvId "SUB" $ \smp -> do
-    liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
-      Left e -> do
-        atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
-          removePendingSubscription c server connId
-        throwError e
-      Right _ -> addSubscription c rq connId
+  withLogSMP c server rcvId "SUB" $ \smp ->
+    subscribeSMPQueue smp rcvPrivateKey rcvId
+  addSubscription c rq connId
 
-addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
+addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
 addSubscription c rq@RcvQueue {server} connId = atomically $ do
-  TM.insert connId server $ subscrConns c
-  addSubs_ (subscrSrvrs c) rq connId
-  removePendingSubscription c server connId
+  modifyTVar (subscrConns c) $ M.insert connId server
+  modifyTVar (subscrSrvrs c) $ M.alter (Just . addSub) server
+  where
+    addSub :: Maybe (Map ConnId RcvQueue) -> Map ConnId RcvQueue
+    addSub (Just cs) = M.insert connId rq cs
+    addSub _ = M.singleton connId rq
 
-hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
-hasActiveSubscription c connId = TM.member connId (subscrConns c)
+removeSubscription :: AgentMonad m => AgentClient -> ConnId -> m ()
+removeSubscription AgentClient {subscrConns, subscrSrvrs} connId = atomically $ do
+  cs <- readTVar subscrConns
+  writeTVar subscrConns $ M.delete connId cs
+  mapM_
+    (modifyTVar subscrSrvrs . M.alter (>>= delSub))
+    (M.lookup connId cs)
+  where
+    delSub :: Map ConnId RcvQueue -> Maybe (Map ConnId RcvQueue)
+    delSub cs =
+      let cs' = M.delete connId cs
+       in if M.null cs' then Nothing else Just cs'
 
-addPendingSubscription :: AgentClient -> RcvQueue -> ConnId -> STM ()
-addPendingSubscription = addSubs_ . pendingSubscrSrvrs
-
-addSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> RcvQueue -> ConnId -> STM ()
-addSubs_ ss rq@RcvQueue {server} connId =
-  TM.lookup server ss >>= \case
-    Just m -> TM.insert connId rq m
-    _ -> TM.singleton connId rq >>= \m -> TM.insert server m ss
-
-removeSubscription :: AgentClient -> ConnId -> STM ()
-removeSubscription c@AgentClient {subscrConns} connId = do
-  server_ <- TM.lookupDelete connId subscrConns
-  mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
-
-removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
-removePendingSubscription = removeSubs_ . pendingSubscrSrvrs
-
-removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> STM ()
-removeSubs_ ss server connId =
-  TM.lookup server ss >>= mapM_ (TM.delete connId)
-
-logServer :: MonadIO m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
+logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
   logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 
 showServer :: SMPServer -> ByteString
-showServer ProtocolServer {host, port} =
+showServer SMPServer {host, port} =
   B.pack $ host <> if null port then "" else ':' : port
 
 logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
 
+-- TODO maybe package E2ERatchetParams into SMPConfirmation
 sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
-sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
-  withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
-    let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
-    msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp Nothing sndId msg
-sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
+sendConfirmation c SndQueue {server, sndId} encConfirmation =
+  withLogSMP_ c server sndId "SEND <CONF>" $ \smp ->
+    liftSMP $ sendSMPMessage smp Nothing sndId encConfirmation
 
 sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
 sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
-  withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
+  withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do
     msg <- mkInvitation
-    liftClient SMP $ sendSMPMessage smp Nothing senderId msg
+    liftSMP $ sendSMPMessage smp Nothing senderId msg
   where
     mkInvitation :: m ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
@@ -483,50 +352,31 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) co
 
 secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
 secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
-  withLogClient c server rcvId "KEY <key>" $ \smp ->
+  withLogSMP c server rcvId "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "ACK" $ \smp ->
+  withLogSMP c server rcvId "ACK" $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId
 
 suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "OFF" $ \smp ->
+  withLogSMP c server rcvId "OFF" $ \smp ->
     suspendSMPQueue smp rcvPrivateKey rcvId
 
 deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "DEL" $ \smp ->
+  withLogSMP c server rcvId "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
+-- TODO this is just wrong
 sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
 sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
-  withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
+  withLogSMP_ c server sndId "SEND <MSG>" $ \smp -> do
     let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
     msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
-
-agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
-agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
-  withClient c ntfServer $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
-
-agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
-agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
-  withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
-
-agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus
-agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
-
-agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
-agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
-
-agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m ()
-agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
-  withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
+    liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do

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

@@ -0,0 +1,88 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+module Simplex.Messaging.Agent.Env.Postgres
+  ( AgentConfig (..),
+    defaultAgentConfig,
+    Env (..),
+    newSMPAgentEnv,
+  )
+where
+
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.List.NonEmpty (NonEmpty)
+import Data.Time.Clock (NominalDiffTime, nominalDay)
+import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
+import Network.Socket
+import Numeric.Natural
+import Simplex.Messaging.Agent.Protocol (SMPServer)
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store.Postgres
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import Simplex.Messaging.Client
+import qualified Simplex.Messaging.Crypto as C
+import System.Random (StdGen, newStdGen)
+import UnliftIO.STM
+
+data AgentConfig = AgentConfig
+  { tcpPort :: ServiceName,
+    smpServers :: NonEmpty SMPServer,
+    cmdSignAlg :: C.SignAlg,
+    connIdBytes :: Int,
+    tbqSize :: Natural,
+    dbConnInfo :: ConnectInfo,
+    dbPoolSize :: Int,
+    smpCfg :: SMPClientConfig,
+    reconnectInterval :: RetryInterval,
+    helloTimeout :: NominalDiffTime,
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: FilePath
+  }
+
+defaultAgentConfig :: AgentConfig
+defaultAgentConfig =
+  AgentConfig
+    { tcpPort = "5224",
+      smpServers = undefined, -- TODO move it elsewhere?
+      cmdSignAlg = C.SignAlg C.SEd448,
+      connIdBytes = 12,
+      tbqSize = 16,
+      dbConnInfo = defaultConnectInfo {connectDatabase = "agent_poc_1"},
+      dbPoolSize = 4,
+      smpCfg = smpDefaultConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = second,
+            increaseAfter = 10 * second,
+            maxInterval = 10 * second
+          },
+      helloTimeout = 7 * nominalDay,
+      -- 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"
+    }
+  where
+    second = 1_000_000
+
+data Env = Env
+  { config :: AgentConfig,
+    store :: PostgresStore,
+    idsDrg :: TVar ChaChaDRG,
+    clientCounter :: TVar Int,
+    randomServer :: TVar StdGen
+  }
+
+newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
+newSMPAgentEnv cfg@AgentConfig {dbConnInfo, dbPoolSize} = do
+  idsDrg <- newTVarIO =<< drgNew
+  store <- liftIO $ createPostgresStore dbConnInfo dbPoolSize Migrations.app
+  clientCounter <- newTVarIO 0
+  randomServer <- newTVarIO =<< liftIO newStdGen
+  return Env {config = cfg, store, idsDrg, clientCounter, randomServer}

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

@@ -2,14 +2,11 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentConfig (..),
-    InitialAgentServers (..),
     defaultAgentConfig,
-    defaultReconnectInterval,
     Env (..),
     newSMPAgentEnv,
   )
@@ -27,65 +24,51 @@ import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Client (NtfServer)
-import Simplex.Messaging.Transport (TLS, Transport (..))
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
 
-data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
-  }
-
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
+    smpServers :: NonEmpty SMPServer,
     cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
     dbFile :: FilePath,
     dbPoolSize :: Int,
-    yesToMigrations :: Bool,
-    smpCfg :: ProtocolClientConfig,
-    ntfCfg :: ProtocolClientConfig,
+    smpCfg :: SMPClientConfig,
     reconnectInterval :: RetryInterval,
     helloTimeout :: NominalDiffTime,
-    resubscriptionConcurrency :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath
   }
 
-defaultReconnectInterval :: RetryInterval
-defaultReconnectInterval =
-  RetryInterval
-    { initialInterval = second,
-      increaseAfter = 10 * second,
-      maxInterval = 10 * second
-    }
-  where
-    second = 1_000_000
-
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
   AgentConfig
     { tcpPort = "5224",
+      smpServers = undefined, -- TODO move it elsewhere?
       cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
-      tbqSize = 64,
+      tbqSize = 16,
       dbFile = "smp-agent.db",
       dbPoolSize = 4,
-      yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
-      ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
-      reconnectInterval = defaultReconnectInterval,
-      helloTimeout = 2 * nominalDay,
-      resubscriptionConcurrency = 16,
+      smpCfg = smpDefaultConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = second,
+            increaseAfter = 10 * second,
+            maxInterval = 10 * second
+          },
+      helloTimeout = 7 * nominalDay,
       -- 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"
     }
+  where
+    second = 1_000_000
 
 data Env = Env
   { config :: AgentConfig,
@@ -96,9 +79,9 @@ data Env = Env
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {dbFile, dbPoolSize, yesToMigrations} = do
+newSMPAgentEnv cfg = do
   idsDrg <- newTVarIO =<< drgNew
-  store <- liftIO $ createSQLiteStore dbFile dbPoolSize Migrations.app yesToMigrations
+  store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
   clientCounter <- newTVarIO 0
   randomServer <- newTVarIO =<< liftIO newStdGen
-  return Env {config, store, idsDrg, clientCounter, randomServer}
+  return Env {config = cfg, store, idsDrg, clientCounter, randomServer}

src/Simplex/Messaging/Agent/Protocol.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -47,11 +46,10 @@ module Simplex.Messaging.Agent.Protocol
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
     AgentMessage (..),
-    AgentMessageType (..),
     APrivHeader (..),
     AMessage (..),
-    SMPServer,
-    pattern SMPServer,
+    AMsgType (..),
+    SMPServer (..),
     SrvLoc (..),
     SMPQueueUri (..),
     SMPQueueInfo (..),
@@ -91,7 +89,7 @@ module Simplex.Messaging.Agent.Protocol
     connModeT,
     serializeQueueStatus,
     queueStatusT,
-    agentMessageType,
+    aMessageType,
 
     -- * TCP transport functions
     tPut,
@@ -133,10 +131,9 @@ import Simplex.Messaging.Protocol
   ( ErrorType,
     MsgBody,
     MsgId,
-    SMPServer,
+    SMPServer (..),
     SndPublicVerifyKey,
     SrvLoc (..),
-    pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
@@ -210,8 +207,8 @@ data ACommand (p :: AParty) where
   CON :: ACommand Agent -- notification that connection is established
   SUB :: ACommand Client
   END :: ACommand Agent
-  DOWN :: SMPServer -> [ConnId] -> ACommand Agent
-  UP :: SMPServer -> [ConnId] -> ACommand Agent
+  DOWN :: ACommand Agent
+  UP :: ACommand Agent
   SEND :: MsgBody -> ACommand Client
   MID :: AgentMsgId -> ACommand Agent
   SENT :: AgentMsgId -> ACommand Agent
@@ -346,31 +343,6 @@ instance Encoding AgentMessage where
       'M' -> AgentMessage <$> smpP <*> smpP
       _ -> fail "bad AgentMessage"
 
-data AgentMessageType = AM_CONN_INFO | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
-  deriving (Eq, Show)
-
-instance Encoding AgentMessageType where
-  smpEncode = \case
-    AM_CONN_INFO -> "C"
-    AM_HELLO_ -> "H"
-    AM_REPLY_ -> "R"
-    AM_A_MSG_ -> "M"
-  smpP =
-    A.anyChar >>= \case
-      'C' -> pure AM_CONN_INFO
-      'H' -> pure AM_HELLO_
-      'R' -> pure AM_REPLY_
-      'M' -> pure AM_A_MSG_
-      _ -> fail "bad AgentMessageType"
-
-agentMessageType :: AgentMessage -> AgentMessageType
-agentMessageType = \case
-  AgentConnInfo _ -> AM_CONN_INFO
-  AgentMessage _ aMsg -> case aMsg of
-    HELLO -> AM_HELLO_
-    REPLY _ -> AM_REPLY_
-    A_MSG _ -> AM_A_MSG_
-
 data APrivHeader = APrivHeader
   { -- | sequential ID assigned by the sending agent
     sndMsgId :: AgentMsgId,
@@ -399,6 +371,12 @@ instance Encoding AMsgType where
       'M' -> pure A_MSG_
       _ -> fail "bad AMsgType"
 
+aMessageType :: AMessage -> AMsgType
+aMessageType = \case
+  HELLO -> HELLO_
+  REPLY _ -> REPLY_
+  A_MSG _ -> A_MSG_
+
 -- | Messages sent between SMP agents once SMP queue is secured.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents
@@ -542,6 +520,7 @@ data SMPQueueUri = SMPQueueUri
   }
   deriving (Eq, Show)
 
+-- TODO change SMP queue URI format to include version range and allow unknown parameters
 instance StrEncoding SMPQueueUri where
   -- v1 uses short SMP queue URI format
   strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
@@ -686,8 +665,6 @@ data AgentErrorType
     CONN {connErr :: ConnectionErrorType}
   | -- | SMP protocol errors forwarded to agent clients
     SMP {smpErr :: ErrorType}
-  | -- | NTF protocol errors forwarded to agent clients
-    NTF {ntfErr :: ErrorType}
   | -- | SMP server errors
     BROKER {brokerErr :: BrokerErrorType}
   | -- | errors of other agents
@@ -728,7 +705,7 @@ data ConnectionErrorType
     SIMPLEX
   | -- | connection not accepted on join HELLO after timeout
     NOT_ACCEPTED
-  | -- | connection not available on reply confirmation/HELLO after timeout
+  | -- | connection not available on reply HELLO after timeout
     NOT_AVAILABLE
   deriving (Eq, Generic, Read, Show, Exception)
 
@@ -776,7 +753,6 @@ instance StrEncoding AgentErrorType where
     "CMD " *> (CMD <$> parseRead1)
       <|> "CONN " *> (CONN <$> parseRead1)
       <|> "SMP " *> (SMP <$> strP)
-      <|> "NTF " *> (NTF <$> strP)
       <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> strP)
       <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
       <|> "BROKER " *> (BROKER <$> parseRead1)
@@ -786,7 +762,6 @@ instance StrEncoding AgentErrorType where
     CMD e -> "CMD " <> bshow e
     CONN e -> "CONN " <> bshow e
     SMP e -> "SMP " <> strEncode e
-    NTF e -> "NTF " <> strEncode e
     BROKER (RESPONSE e) -> "BROKER RESPONSE " <> strEncode e
     BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
     BROKER e -> "BROKER " <> bshow e
@@ -817,8 +792,8 @@ commandP =
     <|> "INFO " *> infoCmd
     <|> "SUB" $> ACmd SClient SUB
     <|> "END" $> ACmd SAgent END
-    <|> "DOWN " *> downsResp
-    <|> "UP " *> upsResp
+    <|> "DOWN" $> ACmd SAgent DOWN
+    <|> "UP" $> ACmd SAgent UP
     <|> "SEND " *> sendCmd
     <|> "MID " *> msgIdResp
     <|> "SENT " *> sentResp
@@ -840,15 +815,12 @@ commandP =
     acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
     rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
     infoCmd = ACmd SAgent . INFO <$> A.takeByteString
-    downsResp = ACmd SAgent .: DOWN <$> strP <* A.space <*> connections
-    upsResp = ACmd SAgent .: UP <$> strP <* A.space <*> connections
     sendCmd = ACmd SClient . SEND <$> A.takeByteString
     msgIdResp = ACmd SAgent . MID <$> A.decimal
     sentResp = ACmd SAgent . SENT <$> A.decimal
     msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
     message = ACmd SAgent .: MSG <$> msgMetaP <* A.space <*> A.takeByteString
     ackCmd = ACmd SClient . ACK <$> A.decimal
-    connections = strP `A.sepBy'` (A.char ',')
     msgMetaP = do
       integrity <- strP
       recipient <- " R=" *> partyMeta A.decimal
@@ -875,8 +847,8 @@ serializeCommand = \case
   INFO cInfo -> "INFO " <> serializeBinary cInfo
   SUB -> "SUB"
   END -> "END"
-  DOWN srv conns -> B.unwords ["DOWN", strEncode srv, connections conns]
-  UP srv conns -> B.unwords ["UP", strEncode srv, connections conns]
+  DOWN -> "DOWN"
+  UP -> "UP"
   SEND msgBody -> "SEND " <> serializeBinary msgBody
   MID mId -> "MID " <> bshow mId
   SENT mId -> "SENT " <> bshow mId
@@ -891,8 +863,6 @@ serializeCommand = \case
   where
     showTs :: UTCTime -> ByteString
     showTs = B.pack . formatISO8601Millis
-    connections :: [ConnId] -> ByteString
-    connections = B.intercalate "," . map strEncode
     serializeMsgMeta :: MsgMeta -> ByteString
     serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
       B.unwords
@@ -944,8 +914,6 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
       ACPT {} -> Right cmd
       -- ERROR response does not always have connId
       ERR _ -> Right cmd
-      DOWN {} -> Right cmd
-      UP {} -> Right cmd
       -- other responses must have connId
       _
         | B.null connId -> Left $ CMD NO_CONN

src/Simplex/Messaging/Agent/Server.hs

@@ -19,7 +19,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Text.Encoding (decodeUtf8)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
@@ -31,17 +31,17 @@ import UnliftIO.STM
 -- | Runs an SMP agent as a TCP service using passed configuration.
 --
 -- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
-runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgent t cfg initServers = do
+runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
+runSMPAgent t cfg = do
   started <- newEmptyTMVarIO
-  runSMPAgentBlocking t started cfg initServers
+  runSMPAgentBlocking t started cfg
 
 -- | Runs an SMP agent as a TCP service using passed configuration with signalling.
 --
 -- 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).
-runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
+runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} = do
   runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
   where
     smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
@@ -50,7 +50,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
       runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
-        c <- getAgentClient initServers
+        c <- getAgentClient
         logConnection c True
         race_ (connectClient h c) (runAgentClient c)
           `E.finally` disconnectAgentClient c

src/Simplex/Messaging/Agent/Store.hs

@@ -20,8 +20,6 @@ import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 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,
     MsgId,
@@ -64,7 +62,7 @@ class Monad m => MonadAgentStore s m where
   createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
   updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
   createSndMsg :: s -> ConnId -> SndMsgData -> m ()
-  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
   getPendingMsgs :: s -> ConnId -> m [InternalId]
   checkRcvMsg :: s -> ConnId -> InternalId -> m ()
   deleteMsg :: s -> ConnId -> InternalId -> m ()
@@ -77,14 +75,6 @@ class Monad m => MonadAgentStore s m where
   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 ()
-
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
@@ -112,11 +102,8 @@ data SndQueue = SndQueue
   { server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
-    -- | key pair used by the sender to sign transmissions
-    sndPublicKey :: Maybe C.APublicVerifyKey,
+    -- | key used by the sender to sign transmissions
     sndPrivateKey :: SndPrivateSignKey,
-    -- | DH public key used to negotiate per-queue e2e encryption
-    e2ePubKey :: Maybe C.PublicKeyX25519,
     -- | shared DH secret agreed for simple per-queue e2e encryption
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
@@ -234,7 +221,7 @@ type PrevSndMsgHash = MsgHash
 
 data RcvMsgData = RcvMsgData
   { msgMeta :: MsgMeta,
-    msgType :: AgentMessageType,
+    msgType :: AMsgType,
     msgBody :: MsgBody,
     internalRcvId :: InternalRcvId,
     internalHash :: MsgHash,
@@ -245,7 +232,7 @@ data SndMsgData = SndMsgData
   { internalId :: InternalId,
     internalSndId :: InternalSndId,
     internalTs :: InternalTs,
-    msgType :: AgentMessageType,
+    msgType :: AMsgType,
     msgBody :: MsgBody,
     internalHash :: MsgHash,
     prevMsgHash :: MsgHash

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

@@ -0,0 +1,957 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Simplex.Messaging.Agent.Store.Postgres
+  ( PostgresStore (..),
+    createPostgresStore,
+    connectPostgresStore,
+    withConnection,
+    withTransaction,
+    fromTextField_,
+    firstRow,
+  )
+where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Control.Monad (void)
+import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Crypto.Random (ChaChaDRG, randomBytesGenerate)
+import Data.Bifunctor (second)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
+import Data.Char (toLower)
+import Data.Functor (($>))
+import Data.List (find, foldl')
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Database.PostgreSQL.Simple (FromRow, Only (..), Query, SqlError, ToRow, withSavepoint)
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.Errors (constraintViolation)
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.Internal (Conversion (..), Field (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import qualified Database.PostgreSQL.Simple.TypeInfo
+import Database.PostgreSQL.Simple.TypeInfo.Static (bytea, text)
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static
+import GHC.Word (Word32)
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.Postgres.Migrations (Migration)
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (blobFieldParser, parseAll)
+import Simplex.Messaging.Protocol (MsgBody)
+import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util (bshow, liftIOEither)
+import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
+import System.Exit (exitFailure)
+import System.FilePath (takeDirectory)
+import System.IO (hFlush, stdout)
+import qualified UnliftIO.Exception as E
+import Network.Socket (HostName, ServiceName)
+import Simplex.Messaging.Crypto (KeyHash)
+
+-- * Postgres Store implementation
+
+data PostgresStore = PostgresStore
+  { dbConnInfo :: DB.ConnectInfo,
+    dbConnPool :: TBQueue DB.Connection,
+    dbNew :: Bool
+  }
+
+createPostgresStore :: DB.ConnectInfo -> Int -> [Migration] -> IO PostgresStore
+createPostgresStore dbConnInfo poolSize migrations = do
+  st <- connectPostgresStore dbConnInfo poolSize
+  migrateSchema st migrations
+  pure st
+
+migrateSchema :: PostgresStore -> [Migration] -> IO ()
+migrateSchema st migrations = withConnection st $ \db -> do
+  Migrations.initialize db
+  Migrations.get db migrations >>= \case
+    Left e -> confirmOrExit $ "Database error: " <> e
+    Right [] -> pure ()
+    Right ms -> do
+      unless (dbNew st) $ do
+        confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
+      -- TODO backup
+      -- let f = dbFilePath st
+      -- copyFile f (f <> ".bak")
+      Migrations.run db ms
+
+confirmOrExit :: String -> IO ()
+confirmOrExit s = do
+  putStrLn s
+  putStr "Continue (y/N): "
+  hFlush stdout
+  ok <- getLine
+  when (map toLower ok /= "y") exitFailure
+
+connectPostgresStore :: DB.ConnectInfo -> Int -> IO PostgresStore
+connectPostgresStore dbConnInfo poolSize = do
+  let dbNew = True -- TODO scan migrations
+  dbConnPool <- newTBQueueIO $ toEnum poolSize
+  replicateM_ poolSize $
+    connectDB dbConnInfo >>= atomically . writeTBQueue dbConnPool
+  pure PostgresStore {dbConnInfo, dbConnPool, dbNew}
+
+connectDB :: DB.ConnectInfo -> IO DB.Connection
+connectDB = DB.connect
+
+checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
+checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
+
+handleSQLError :: StoreError -> SqlError -> StoreError
+handleSQLError err e = case constraintViolation e of
+  Just _ -> err
+  Nothing -> SEInternal $ bshow e
+
+withConnection :: PostgresStore -> (DB.Connection -> IO a) -> IO a
+withConnection PostgresStore {dbConnPool} =
+  bracket
+    (atomically $ readTBQueue dbConnPool)
+    (atomically . writeTBQueue dbConnPool)
+
+execute :: ToRow q => DB.Connection -> Query -> q -> IO ()
+execute db query q = void $ DB.execute db query q
+
+-- TODO not sure this logic is needed with Postgres, also no such error
+-- withTransaction :: forall a. PostgresStore -> (DB.Connection -> IO a) -> IO a
+-- withTransaction st action = withConnection st $ loop 100 100_000
+--   where
+--     loop :: Int -> Int -> DB.Connection -> IO a
+--     loop t tLim db =
+--       DB.withTransaction db (action db) `E.catch` \(e :: SQLError) ->
+--         if tLim > t && DB.sqlError e == DB.ErrorBusy
+--           then do
+--             threadDelay t
+--             loop (t * 9 `div` 8) (tLim - t) db
+--           else E.throwIO e
+
+withTransaction :: forall a. PostgresStore -> (DB.Connection -> IO a) -> IO a
+withTransaction st action = withConnection st inTransaction
+  where
+    inTransaction :: DB.Connection -> IO a
+    inTransaction db = DB.withTransaction db (action db)
+
+createConn_ ::
+  (MonadUnliftIO m, MonadError StoreError m) =>
+  PostgresStore ->
+  TVar ChaChaDRG ->
+  ConnData ->
+  (DB.Connection -> ByteString -> IO ()) ->
+  m ByteString
+createConn_ st gVar cData create = do
+  connId <- liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->
+    case cData of
+      ConnData {connId = ""} -> createWithRandomId gVar $ create db
+      ConnData {connId} -> create db connId $> Right connId
+  liftIO $ print "before: getConn_ db connId"
+  conn <- liftIO $ withTransaction st $ \db -> getConn_ db connId
+  liftIO $ print conn
+  pure connId
+
+instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore PostgresStore m where
+  createRcvConn :: PostgresStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
+  createRcvConn st gVar cData q@RcvQueue {server} cMode =
+    createConn_ st gVar cData $ \db connId -> do
+      upsertServer_ db server
+      execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, cMode)
+      insertRcvQueue_ db connId q
+
+  createSndConn :: PostgresStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
+  createSndConn st gVar cData q@SndQueue {server} =
+    createConn_ st gVar cData $ \db connId -> do
+      upsertServer_ db server
+      execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, SCMInvitation)
+      insertSndQueue_ db connId q
+
+  getConn :: PostgresStore -> ConnId -> m SomeConn
+  getConn st connId =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId
+
+  getRcvConn :: PostgresStore -> SMPServer -> SMP.RecipientId -> m SomeConn
+  getRcvConn st SMPServer {host, port} rcvId =
+    liftIOEither . withTransaction st $ \db ->
+      DB.query
+        db
+        [sql|
+          SELECT q.conn_id
+          FROM rcv_queues q
+          WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?;
+        |]
+        (host, port, rcvId)
+        >>= \case
+          [Only connId] -> getConn_ db connId
+          _ -> pure $ Left SEConnNotFound
+
+  deleteConn :: PostgresStore -> ConnId -> m ()
+  deleteConn st connId =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        "DELETE FROM connections WHERE conn_id = ?;"
+        (Only connId)
+
+  upgradeRcvConnToDuplex :: PostgresStore -> ConnId -> SndQueue -> m ()
+  upgradeRcvConnToDuplex st connId sq@SndQueue {server} =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId >>= \case
+        Right (SomeConn _ RcvConnection {}) -> do
+          upsertServer_ db server
+          insertSndQueue_ db connId sq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
+
+  upgradeSndConnToDuplex :: PostgresStore -> ConnId -> RcvQueue -> m ()
+  upgradeSndConnToDuplex st connId rq@RcvQueue {server} =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId >>= \case
+        Right (SomeConn _ SndConnection {}) -> do
+          upsertServer_ db server
+          insertRcvQueue_ db connId rq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
+
+  setRcvQueueStatus :: PostgresStore -> RcvQueue -> QueueStatus -> m ()
+  setRcvQueueStatus st RcvQueue {rcvId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue does not exist?
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET status = ?
+          WHERE host = ? AND port = ? AND rcv_id = ?;
+        |]
+        (status, host, port, rcvId)
+
+  setRcvQueueConfirmedE2E :: PostgresStore -> RcvQueue -> C.DhSecretX25519 -> m ()
+  setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eDhSecret =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET e2e_dh_secret = ?,
+              status = ?
+          WHERE host = ? AND port = ? AND rcv_id = ?
+        |]
+        (Confirmed, e2eDhSecret, host, port, rcvId)
+
+  setSndQueueStatus :: PostgresStore -> SndQueue -> QueueStatus -> m ()
+  setSndQueueStatus st SndQueue {sndId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue does not exist?
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE snd_queues
+          SET status = ?
+          WHERE host = ? AND port = ? AND snd_id = ?;
+        |]
+        (status, host, port, sndId)
+
+  createConfirmation :: PostgresStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
+  createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}, ratchetState} =
+    liftIOEither . withTransaction st $ \db ->
+      createWithRandomId gVar $ \confirmationId ->
+        execute
+          db
+          [sql|
+            INSERT INTO conn_confirmations
+            (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, ?, 0);
+          |]
+          (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo)
+
+  acceptConfirmation :: PostgresStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
+  acceptConfirmation st confirmationId ownConnInfo =
+    liftIOEither . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          UPDATE conn_confirmations
+          SET accepted = 1,
+              own_conn_info = ?
+          WHERE confirmation_id = ?;
+        |]
+        (ownConnInfo, confirmationId)
+      firstRow confirmation SEConfirmationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info
+            FROM conn_confirmations
+            WHERE confirmation_id = ?;
+          |]
+          (Only confirmationId)
+    where
+      confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo) =
+        AcceptedConfirmation
+          { confirmationId,
+            connId,
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            ratchetState,
+            ownConnInfo
+          }
+
+  getAcceptedConfirmation :: PostgresStore -> ConnId -> m AcceptedConfirmation
+  getAcceptedConfirmation st connId =
+    liftIOEither . withTransaction st $ \db ->
+      firstRow confirmation SEConfirmationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, own_conn_info
+            FROM conn_confirmations
+            WHERE conn_id = ? AND accepted = 1;
+          |]
+          (Only connId)
+    where
+      confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, ownConnInfo) =
+        AcceptedConfirmation
+          { confirmationId,
+            connId,
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            ratchetState,
+            ownConnInfo
+          }
+
+  removeConfirmations :: PostgresStore -> ConnId -> m ()
+  removeConfirmations st connId =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          DELETE FROM conn_confirmations
+          WHERE conn_id = ?;
+        |]
+        (Only connId)
+
+  createInvitation :: PostgresStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
+  createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =
+    liftIOEither . withTransaction st $ \db ->
+      createWithRandomId gVar $ \invitationId ->
+        execute
+          db
+          [sql|
+            INSERT INTO conn_invitations
+            (invitation_id,  contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
+          |]
+          (invitationId, contactConnId, connReq, recipientConnInfo)
+
+  getInvitation :: PostgresStore -> InvitationId -> m Invitation
+  getInvitation st invitationId =
+    liftIOEither . withTransaction st $ \db ->
+      firstRow invitation SEInvitationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted
+            FROM conn_invitations
+            WHERE invitation_id = ?
+              AND accepted = 0
+          |]
+          (Only invitationId)
+    where
+      invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) =
+        Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}
+
+  acceptInvitation :: PostgresStore -> InvitationId -> ConnInfo -> m ()
+  acceptInvitation st invitationId ownConnInfo =
+    liftIO . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          UPDATE conn_invitations
+          SET accepted = 1,
+              own_conn_info = ?
+          WHERE invitation_id = ?
+        |]
+        (ownConnInfo, invitationId)
+
+  deleteInvitation :: PostgresStore -> ConnId -> InvitationId -> m ()
+  deleteInvitation st contactConnId invId =
+    liftIOEither . withTransaction st $ \db ->
+      runExceptT $
+        ExceptT (getConn_ db contactConnId) >>= \case
+          SomeConn SCContact _ ->
+            liftIO $ execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId)
+          _ -> throwError SEConnNotFound
+
+  updateRcvIds :: PostgresStore -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  updateRcvIds st connId =
+    liftIO . withTransaction st $ \db -> do
+      (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1
+      updateLastIdsRcv_ db connId internalId internalRcvId
+      pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
+
+  createRcvMsg :: PostgresStore -> ConnId -> RcvMsgData -> m ()
+  createRcvMsg st connId rcvMsgData =
+    liftIO . withTransaction st $ \db -> do
+      insertRcvMsgBase_ db connId rcvMsgData
+      insertRcvMsgDetails_ db connId rcvMsgData
+      updateHashRcv_ db connId rcvMsgData
+
+  updateSndIds :: PostgresStore -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  updateSndIds st connId =
+    liftIO . withTransaction st $ \db -> do
+      (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
+      updateLastIdsSnd_ db connId internalId internalSndId
+      pure (internalId, internalSndId, prevSndHash)
+
+  createSndMsg :: PostgresStore -> ConnId -> SndMsgData -> m ()
+  createSndMsg st connId sndMsgData =
+    liftIO . withTransaction st $ \db -> do
+      insertSndMsgBase_ db connId sndMsgData
+      insertSndMsgDetails_ db connId sndMsgData
+      updateHashSnd_ db connId sndMsgData
+
+  getPendingMsgData :: PostgresStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
+  getPendingMsgData st connId msgId =
+    liftIOEither . withTransaction st $ \db -> runExceptT $ do
+      rq_ <- liftIO $ getRcvQueueByConnId_ db connId
+      msgData <-
+        ExceptT . firstRow id SEMsgNotFound $
+          DB.query
+            db
+            [sql|
+                SELECT m.msg_type, m.msg_body, m.internal_ts
+                FROM messages m
+                JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
+                WHERE m.conn_id = ? AND m.internal_id = ?
+              |]
+            (connId, msgId)
+      pure (rq_, msgData)
+
+  getPendingMsgs :: PostgresStore -> ConnId -> m [InternalId]
+  getPendingMsgs st connId =
+    liftIO . withTransaction st $ \db ->
+      map fromOnly
+        <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)
+
+  checkRcvMsg :: PostgresStore -> ConnId -> InternalId -> m ()
+  checkRcvMsg st connId msgId =
+    liftIOEither . withTransaction st $ \db ->
+      hasMsg
+        <$> DB.query
+          db
+          [sql|
+            SELECT conn_id, internal_id
+            FROM rcv_messages
+            WHERE conn_id = ? AND internal_id = ?
+          |]
+          (connId, msgId)
+    where
+      hasMsg :: [(ConnId, InternalId)] -> Either StoreError ()
+      hasMsg r = if null r then Left SEMsgNotFound else Right ()
+
+  deleteMsg :: PostgresStore -> ConnId -> InternalId -> m ()
+  deleteMsg st connId msgId =
+    liftIO . withTransaction st $ \db ->
+      execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
+
+  createRatchetX3dhKeys :: PostgresStore -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
+  createRatchetX3dhKeys st connId x3dhPrivKey1 x3dhPrivKey2 =
+    liftIO . withTransaction st $ \db ->
+      execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
+
+  getRatchetX3dhKeys :: PostgresStore -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
+  getRatchetX3dhKeys st connId =
+    liftIOEither . withTransaction st $ \db ->
+      fmap hasKeys $
+        firstRow id SEX3dhKeysNotFound $
+          DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
+    where
+      hasKeys = \case
+        Right (Just k1, Just k2) -> Right (k1, k2)
+        _ -> Left SEX3dhKeysNotFound
+
+  createRatchet :: PostgresStore -> ConnId -> RatchetX448 -> m ()
+  createRatchet st connId rc =
+    liftIO . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          INSERT INTO ratchets (conn_id, ratchet_state)
+          VALUES (?, ?)
+          ON CONFLICT (conn_id) DO UPDATE SET
+            ratchet_state = ?,
+            x3dh_priv_key_1 = NULL,
+            x3dh_priv_key_2 = NULL
+        |]
+        (connId, rc, rc)
+
+  getRatchet :: PostgresStore -> ConnId -> m RatchetX448
+  getRatchet st connId =
+    liftIOEither . withTransaction st $ \db ->
+      ratchet
+        <$> DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId)
+    where
+      ratchet (Only (Just rc) : _) = Right rc
+      ratchet _ = Left SERatchetNotFound
+
+  getSkippedMsgKeys :: PostgresStore -> ConnId -> m SkippedMsgKeys
+  getSkippedMsgKeys st connId =
+    liftIO . withTransaction st $ \db ->
+      skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)
+    where
+      skipped ms = foldl' addSkippedKey M.empty ms
+      addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
+        where
+          addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk)
+
+  updateRatchet :: PostgresStore -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
+  updateRatchet st connId rc skipped =
+    liftIO . withTransaction st $ \db -> do
+      execute db "UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?" (rc, connId)
+      case skipped of
+        SMDNoChange -> pure ()
+        SMDRemove hk msgN ->
+          execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND header_key = ? AND msg_n = ?" (connId, hk, msgN)
+        SMDAdd smks ->
+          forM_ (M.assocs smks) $ \(hk, mks) ->
+            forM_ (M.assocs mks) $ \(msgN, mk) ->
+              execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
+
+-- -- * Auxiliary helpers
+
+instance ToField QueueStatus where toField = toField . serializeQueueStatus
+
+instance FromField QueueStatus where fromField = fromTextField_ queueStatusT
+
+instance ToField InternalRcvId where toField (InternalRcvId x) = toField x
+
+instance FromField InternalRcvId where fromField x = fromField x
+
+instance ToField InternalSndId where toField (InternalSndId x) = toField x
+
+instance FromField InternalSndId where fromField x = fromField x
+
+instance ToField InternalId where toField (InternalId x) = toField x
+
+instance FromField InternalId where fromField x = fromField x
+
+instance ToField AMsgType where toField = toField . smpEncode
+
+instance FromField AMsgType where fromField = fromByteStringField $ parseAll smpP
+
+instance ToField MsgIntegrity where toField = toField . strEncode
+
+instance FromField MsgIntegrity where fromField = fromByteStringField $ parseAll strP
+
+instance ToField SMPQueueUri where toField = toField . strEncode
+
+instance FromField SMPQueueUri where fromField = fromByteStringField $ parseAll strP
+
+instance ToField AConnectionRequestUri where toField = toField . strEncode
+
+instance FromField AConnectionRequestUri where fromField = fromByteStringField $ parseAll strP
+
+instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode
+
+instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = fromByteStringField $ parseAll strP
+
+instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode
+
+instance FromField ConnectionMode where fromField = fromTextField_ connModeT
+
+instance ToField (SConnectionMode c) where toField = toField . connMode
+
+instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT
+
+instance FromField Word32 where fromField x = fromField x
+
+fromTextField_ :: E.Typeable a => (Text -> Maybe a) -> Field -> Maybe ByteString -> Conversion a
+fromTextField_ fromText f mdata =
+  if typeOid f /= typoid text
+    then returnError Incompatible f ""
+    else case mdata of
+      Nothing -> returnError UnexpectedNull f ""
+      Just dat ->
+        case fromText ((T.pack . B.unpack) dat) of
+          Just x -> return x
+          _ -> returnError ConversionFailed f (B.unpack dat)
+
+-- TODO same as in Crypto
+fromByteStringField :: E.Typeable a => (ByteString -> Either String a) -> Field -> Maybe ByteString -> Conversion a
+fromByteStringField dec f mdata =
+  if typeOid f /= typoid bytea
+    then returnError Incompatible f ""
+    else case mdata of
+      Nothing -> returnError UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> returnError ConversionFailed f (B.unpack dat)
+
+listToEither :: e -> [a] -> Either e a
+listToEither _ (x : _) = Right x
+listToEither e _ = Left e
+
+firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
+firstRow f e a = second f . listToEither e <$> a
+
+-- {- ORMOLU_DISABLE -}
+-- -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
+-- instance (FromField a, FromField b, FromField c, FromField d, FromField e,
+--           FromField f, FromField g, FromField h, FromField i, FromField j,
+--           FromField k) =>
+--   FromRow (a,b,c,d,e,f,g,h,i,j,k) where
+--   fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
+--                          <*> field <*> field <*> field <*> field <*> field
+--                          <*> field
+
+-- instance (FromField a, FromField b, FromField c, FromField d, FromField e,
+--           FromField f, FromField g, FromField h, FromField i, FromField j,
+--           FromField k, FromField l) =>
+--   FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where
+--   fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
+--                           <*> field <*> field <*> field <*> field <*> field
+--                           <*> field <*> field
+
+-- instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
+--           ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) =>
+--   ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where
+--   toRow (a,b,c,d,e,f,g,h,i,j,k,l) =
+--     [ toField a, toField b, toField c, toField d, toField e, toField f,
+--       toField g, toField h, toField i, toField j, toField k, toField l
+--     ]
+
+-- {- ORMOLU_ENABLE -}
+
+-- * Server upsert helper
+
+upsertServer_ :: DB.Connection -> SMPServer -> IO ()
+upsertServer_ dbConn SMPServer {host, port, keyHash} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO servers (host, port, key_hash) VALUES (?,?,?)
+      ON CONFLICT (host, port) DO UPDATE SET
+        host=excluded.host,
+        port=excluded.port,
+        key_hash=excluded.key_hash;
+    |]
+    (host, port, keyHash)
+
+-- * createRcvConn helpers
+
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
+insertRcvQueue_ dbConn connId RcvQueue {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO rcv_queues
+        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status)
+      VALUES
+        (?,?,?,?,?,?,?,?,?,?);
+    |]
+    (host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
+
+-- * createSndConn helpers
+
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
+insertSndQueue_ dbConn connId SndQueue {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO snd_queues
+        ( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)
+      VALUES
+        (?,?,?,?,?,?,?);
+    |]
+    (host server, port server, DB.Binary sndId, connId, sndPrivateKey, e2eDhSecret, status)
+
+-- * getConn helpers
+
+getConn_ :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
+getConn_ dbConn connId =
+  getConnData_ dbConn connId >>= \case
+    Nothing -> pure $ Left SEConnNotFound
+    Just (connData, cMode) -> do
+      liftIO $ print "before: getRcvQueueByConnId_ dbConn connId"
+      rQ <- getRcvQueueByConnId_ dbConn connId
+      liftIO $ print $ "rQ: " <> show rQ
+      liftIO $ print "before: getSndQueueByConnId_ dbConn connId"
+      sQ <- getSndQueueByConnId_ dbConn connId
+      liftIO $ print $ "sQ: " <> show sQ
+      liftIO $ print "after: getSndQueueByConnId_ dbConn connId"
+      pure $ case (rQ, sQ, cMode) of
+        (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)
+        (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)
+        (Nothing, Just sndQ, CMInvitation) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)
+        (Just rcvQ, Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection connData rcvQ)
+        _ -> Left SEConnNotFound
+
+getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData_ dbConn connId' =
+  connData
+    <$> DB.query dbConn "SELECT conn_id, conn_mode FROM connections WHERE conn_id = ?;" (Only connId')
+  where
+    connData [(connId, cMode)] = Just (ConnData {connId}, cMode)
+    connData _ = Nothing
+
+getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
+getRcvQueueByConnId_ dbConn connId =
+  rcvQueue
+    <$> DB.query
+      dbConn
+      [sql|
+        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
+          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status
+        FROM rcv_queues q
+        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+        WHERE q.conn_id = ?;
+      |]
+      (Only connId)
+  where
+    rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)] =
+      let server = SMPServer host port keyHash
+       in Just RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status}
+    rcvQueue _ = Nothing
+
+getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
+getSndQueueByConnId_ dbConn connId = do
+  -- sndQueue
+  --   <$> DB.query
+  --     dbConn
+  --     -- [sql|
+  --     --   SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
+  --     --   FROM snd_queues q
+  --     --   INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+  --     --   WHERE q.conn_id = ?;
+  --     -- |]
+  --     [sql|
+  --       SELECT s.key_hash, q.host, q.port, q.snd_private_key, q.status
+  --       FROM snd_queues q
+  --       INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+  --       WHERE q.conn_id = ?;
+  --     |]
+  --     (Only connId)
+  print "inside: getSndQueueByConnId_"
+  -- r1 <- (DB.query
+  --     dbConn
+  --     [sql|
+  --       SELECT host, port, key_hash
+  --       FROM servers
+  --       WHERE host = ?
+  --     |]
+  --     (DB.Only ("localhost" :: HostName))) :: (IO [(HostName, ServiceName, KeyHash)])
+  -- putStrLn $ show r1
+  r <- DB.query
+      dbConn
+      [sql|
+        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
+        FROM snd_queues q
+        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+        WHERE q.conn_id = ?;
+      |]
+      -- [sql|
+      --   SELECT q.host, q.port, q.status
+      --   FROM snd_queues q
+      --   INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+      --   WHERE q.conn_id = ?;
+      -- |]
+      (DB.Only connId)
+  print $ "r: " <> show r
+  let q = sndQueue r
+  print $ "q: " <> show q
+  pure q
+  where
+    sndQueue [(keyHash, host, port, DB.Binary sndId, sndPrivateKey, e2eDhSecret, status)] =
+      let server = SMPServer host port keyHash
+       in Just SndQueue {server, sndId, sndPrivateKey, e2eDhSecret, status}
+    sndQueue _ = Nothing
+    -- sndQueue [(host, port, status)] = do
+    --   let server = SMPServer host port "abcd"
+    --    in Just SndQueue {server, sndId="3456", sndPrivateKey=(C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"), e2eDhSecret="MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=", status}
+    -- sndQueue _ = Nothing
+
+-- * updateRcvIds helpers
+
+retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+retrieveLastIdsAndHashRcv_ dbConn connId = do
+  [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <-
+    DB.query
+      dbConn
+      [sql|
+        SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash
+        FROM connections
+        WHERE conn_id = ?;
+      |]
+      (Only connId)
+  return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)
+
+updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO ()
+updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId =
+  execute
+    dbConn
+    [sql|
+      UPDATE connections
+      SET last_internal_msg_id = :last_internal_msg_id,
+          last_internal_rcv_msg_id = :last_internal_rcv_msg_id
+      WHERE conn_id = :conn_id;
+    |]
+    (newInternalId, newInternalRcvId, connId)
+
+-- * createRcvMsg helpers
+
+insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgBody, internalRcvId} = do
+  let MsgMeta {recipient = (internalId, internalTs)} = msgMeta
+  execute
+    dbConn
+    [sql|
+      INSERT INTO messages
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+      VALUES
+        (?,?,?,?,NULL,?,?);
+    |]
+    (connId, internalId, internalTs, internalRcvId, msgType, msgBody)
+
+insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+insertRcvMsgDetails_ dbConn connId RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
+  let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta
+  execute
+    dbConn
+    [sql|
+      INSERT INTO rcv_messages
+        ( conn_id, internal_rcv_id, internal_id, external_snd_id,
+          broker_id, broker_ts,
+          internal_hash, external_prev_snd_hash, integrity)
+      VALUES
+        (?,?,?,?,
+         ?,?,
+         ?,?,?);
+    |]
+    (connId, internalRcvId, fst recipient, sndMsgId, fst broker, snd broker, internalHash, externalPrevSndHash, integrity)
+
+updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} =
+  execute
+    dbConn
+    -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved
+    [sql|
+      UPDATE connections
+      SET last_external_snd_msg_id = ?,
+          last_rcv_msg_hash = ?
+      WHERE conn_id = ?
+        AND last_internal_rcv_msg_id = ?;
+    |]
+    (sndMsgId (msgMeta :: MsgMeta), internalHash, connId, internalRcvId)
+
+-- * updateSndIds helpers
+
+retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
+retrieveLastIdsAndHashSnd_ dbConn connId = do
+  [(lastInternalId, lastInternalSndId, lastSndHash)] <-
+    DB.query
+      dbConn
+      [sql|
+        SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash
+        FROM connections
+        WHERE conn_id = ?;
+      |]
+      (Only connId)
+  return (lastInternalId, lastInternalSndId, lastSndHash)
+
+updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()
+updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
+  execute
+    dbConn
+    [sql|
+      UPDATE connections
+      SET last_internal_msg_id = ?,
+          last_internal_snd_msg_id = ?
+      WHERE conn_id = ?;
+    |]
+    (newInternalId, newInternalSndId, connId)
+
+-- * createSndMsg helpers
+
+insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+insertSndMsgBase_ dbConn connId SndMsgData {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO messages
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+      VALUES
+        (?,?,?,NULL,?,?, ?);
+    |]
+    (connId, internalId, internalTs, internalSndId, msgType, msgBody)
+
+insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+insertSndMsgDetails_ dbConn connId SndMsgData {..} =
+  execute
+    dbConn
+    [sql|
+      INSERT INTO snd_messages
+        ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash)
+      VALUES
+        (?,?,?,?,?);
+    |]
+    (connId, internalSndId, internalId, internalHash, prevMsgHash)
+
+updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+updateHashSnd_ dbConn connId SndMsgData {..} =
+  execute
+    dbConn
+    -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved
+    [sql|
+      UPDATE connections
+      SET last_snd_msg_hash = ?
+      WHERE conn_id = ?
+        AND last_internal_snd_msg_id = ?;
+    |]
+    (internalHash, connId, internalSndId)
+
+-- create record with a random ID
+createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
+createWithRandomId gVar create = tryCreate 3
+  where
+    tryCreate :: Int -> IO (Either StoreError ByteString)
+    tryCreate 0 = pure $ Left SEUniqueID
+    tryCreate n = do
+      id' <- randomId gVar 12
+      E.try (create id') >>= \case
+        Right _ -> pure $ Right id'
+        Left e -> case constraintViolation e of
+          Just _ -> tryCreate (n - 1)
+          Nothing -> pure . Left . SEInternal $ bshow e
+
+randomId :: TVar ChaChaDRG -> Int -> IO ByteString
+randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)

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

@@ -0,0 +1,73 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations
+  ( Migration (..),
+    app,
+    initialize,
+    get,
+    run,
+  )
+where
+
+import Control.Monad (forM_, void)
+import Data.Function (on)
+import Data.List (intercalate, sortBy)
+import Data.Time.Clock (getCurrentTime)
+import Database.PostgreSQL.Simple (Connection, Only (..))
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.Internal (exec)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.Transaction (withTransaction)
+import Database.PostgreSQL.Simple.Types (Query (..))
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial (m20220202_initial)
+
+data Migration = Migration {name :: String, up :: Query}
+  deriving (Show)
+
+schemaMigrations :: [(String, Query)]
+schemaMigrations =
+  [ ("20220101_initial", m20220202_initial)
+  ]
+
+-- | The list of migrations in ascending order by date
+app :: [Migration]
+app = sortBy (compare `on` name) $ map migration schemaMigrations
+  where
+    migration (name, query) = Migration {name, up = query}
+
+get :: Connection -> [Migration] -> IO (Either String [Migration])
+get conn migrations =
+  migrationsToRun migrations . map fromOnly
+    <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
+
+run :: Connection -> [Migration] -> IO ()
+run conn ms = withTransaction conn . forM_ ms $
+  \Migration {name, up} -> insert name >> exec conn (fromQuery up)
+  where
+    insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
+
+initialize :: Connection -> IO ()
+initialize conn =
+  void $
+    DB.execute_
+      conn
+      [sql|
+    CREATE TABLE IF NOT EXISTS migrations (
+      name TEXT NOT NULL,
+      ts TEXT NOT NULL,
+      PRIMARY KEY (name)
+    );
+  |]
+
+migrationsToRun :: [Migration] -> [String] -> Either String [Migration]
+migrationsToRun appMs [] = Right appMs
+migrationsToRun [] dbMs = Left $ "database version is newer than the app: " <> intercalate ", " dbMs
+migrationsToRun (a : as) (d : ds)
+  | name a == d = migrationsToRun as ds
+  | otherwise = Left $ "different migration in the app/database: " <> name a <> " / " <> d

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20220202_initial.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial where
+
+import Database.PostgreSQL.Simple (Query)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+
+m20220202_initial :: Query
+m20220202_initial =
+  [sql|
+-- for easy testing
+DROP SCHEMA public CASCADE;
+CREATE SCHEMA public;
+
+CREATE TABLE servers (
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  key_hash BYTEA NOT NULL,
+  PRIMARY KEY (host, port)
+);
+
+CREATE TABLE connections (
+  conn_id BYTEA NOT NULL PRIMARY KEY,
+  conn_mode TEXT NOT NULL,
+  last_internal_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_rcv_msg_hash BYTEA NOT NULL DEFAULT '',
+  last_snd_msg_hash BYTEA NOT NULL DEFAULT '',
+  smp_agent_version INTEGER NOT NULL DEFAULT 1
+);
+
+CREATE TABLE rcv_queues (
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  rcv_id BYTEA NOT NULL,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  rcv_private_key BYTEA NOT NULL,
+  rcv_dh_secret BYTEA NOT NULL,
+  e2e_priv_key BYTEA NOT NULL,
+  e2e_dh_secret BYTEA,
+  snd_id BYTEA NOT NULL,
+  snd_key BYTEA,
+  status TEXT NOT NULL,
+  smp_server_version INTEGER NOT NULL DEFAULT 1,
+  smp_client_version INTEGER,
+  PRIMARY KEY (host, port, rcv_id),
+  FOREIGN KEY (host, port) REFERENCES servers
+    ON DELETE RESTRICT ON UPDATE CASCADE,
+  UNIQUE (host, port, snd_id)
+);
+
+CREATE TABLE snd_queues (
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  snd_id BYTEA NOT NULL,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  snd_private_key BYTEA NOT NULL,
+  e2e_dh_secret BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  smp_server_version INTEGER NOT NULL DEFAULT 1,
+  smp_client_version INTEGER NOT NULL DEFAULT 1,
+  PRIMARY KEY (host, port, snd_id),
+  FOREIGN KEY (host, port) REFERENCES servers
+    ON DELETE RESTRICT ON UPDATE CASCADE
+);
+
+CREATE TABLE messages (
+  conn_id BYTEA NOT NULL REFERENCES connections (conn_id)
+    ON DELETE CASCADE,
+  internal_id INTEGER NOT NULL,
+  internal_ts TIMESTAMP NOT NULL,
+  internal_rcv_id INTEGER,
+  internal_snd_id INTEGER,
+  msg_type BYTEA NOT NULL, -- (H)ELLO, (R)EPLY, (D)ELETE. Should SMP confirmation be saved too?
+  msg_body BYTEA NOT NULL DEFAULT '',
+  PRIMARY KEY (conn_id, internal_id)
+);
+
+CREATE TABLE rcv_messages (
+  conn_id BYTEA NOT NULL,
+  internal_rcv_id INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  external_snd_id INTEGER NOT NULL,
+  broker_id BYTEA NOT NULL,
+  broker_ts TIMESTAMP NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  external_prev_snd_hash BYTEA NOT NULL,
+  integrity BYTEA NOT NULL, -- in the list of keywords
+  PRIMARY KEY (conn_id, internal_rcv_id),
+  FOREIGN KEY (conn_id, internal_id) REFERENCES messages
+    ON DELETE CASCADE
+);
+
+ALTER TABLE messages
+ADD CONSTRAINT fk_messages_rcv_messages
+  FOREIGN KEY (conn_id, internal_rcv_id) REFERENCES rcv_messages
+  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED;
+
+CREATE TABLE snd_messages (
+  conn_id BYTEA NOT NULL,
+  internal_snd_id INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  previous_msg_hash BYTEA NOT NULL DEFAULT '',
+  PRIMARY KEY (conn_id, internal_snd_id),
+  FOREIGN KEY (conn_id, internal_id) REFERENCES messages
+    ON DELETE CASCADE
+);
+
+ALTER TABLE messages
+ADD CONSTRAINT fk_messages_snd_messages
+  FOREIGN KEY (conn_id, internal_snd_id) REFERENCES snd_messages
+  ON DELETE CASCADE DEFERRABLE INITIALLY deferred;
+
+CREATE TABLE conn_confirmations (
+  confirmation_id BYTEA NOT NULL PRIMARY KEY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  e2e_snd_pub_key BYTEA NOT NULL, -- TODO per-queue key. Split?
+  sender_key BYTEA NOT NULL, -- TODO per-queue key. Split?
+  ratchet_state BYTEA NOT NULL,
+  sender_conn_info BYTEA NOT NULL,
+  accepted INTEGER NOT NULL,
+  own_conn_info BYTEA,
+  created_at TIMESTAMP NOT NULL DEFAULT (now())
+);
+
+CREATE TABLE conn_invitations (
+  invitation_id BYTEA NOT NULL PRIMARY KEY,
+  contact_conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  cr_invitation BYTEA NOT NULL,
+  recipient_conn_info BYTEA NOT NULL,
+  accepted INTEGER NOT NULL DEFAULT 0,
+  own_conn_info BYTEA,
+  created_at TIMESTAMP NOT NULL DEFAULT (now())
+);
+
+CREATE TABLE ratchets (
+  conn_id BYTEA NOT NULL PRIMARY KEY REFERENCES connections
+    ON DELETE CASCADE,
+  -- x3dh keys are not saved on the sending side (the side accepting the connection)
+  x3dh_priv_key_1 BYTEA,
+  x3dh_priv_key_2 BYTEA,
+  -- ratchet is initially empty on the receiving side (the side offering the connection)
+  ratchet_state BYTEA,
+  e2e_version INTEGER NOT NULL DEFAULT 1
+);
+
+CREATE TABLE skipped_messages (
+  skipped_message_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES ratchets
+    ON DELETE CASCADE,
+  header_key BYTEA NOT NULL,
+  msg_n INTEGER NOT NULL,
+  msg_key BYTEA NOT NULL
+);
+|]

src/Simplex/Messaging/Agent/Store/Postgres/README.md

@@ -0,0 +1,9 @@
+# Postgres setup
+
+Create three databases - `agent_poc_1`, `agent_poc_2`, `agent_poc_3` - and have Postgres server running.
+
+~~`brew install postgresql` - required by postgresql-simple.~~
+
+~~You may run into compilation errors, then you might also need to `brew install libpq --build-from-source`, see [this Stack Overflow answer](https://stackoverflow.com/a/70012033).~~
+
+In the end I managed to build using cabal.

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

@@ -9,7 +9,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -23,6 +22,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     connectSQLiteStore,
     withConnection,
     withTransaction,
+    fromTextField_,
     firstRow,
   )
 where
@@ -33,21 +33,21 @@ import Control.Exception (bracket)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
-import Data.Bifunctor (first, second)
+import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
 import Data.Functor (($>))
-import Data.List (find, foldl', partition)
+import Data.List (find, foldl')
 import qualified Data.Map.Strict as M
-import Data.Maybe (listToMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLError, ToRow, field, (:.) (..))
+import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, ToRow, field)
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.Internal (Field (..))
+import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.QQ (sql)
 import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol
@@ -58,10 +58,8 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Client (NtfServer, NtfTknAction, NtfToken (..))
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus (..), NtfTokenId)
-import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
-import Simplex.Messaging.Protocol (MsgBody, ProtocolServer (..))
+import Simplex.Messaging.Parsers (blobFieldParser)
+import Simplex.Messaging.Protocol (MsgBody)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Util (bshow, liftIOEither)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
@@ -78,13 +76,13 @@ data SQLiteStore = SQLiteStore
     dbNew :: Bool
   }
 
-createSQLiteStore :: FilePath -> Int -> [Migration] -> Bool -> IO SQLiteStore
-createSQLiteStore dbFilePath poolSize migrations yesToMigrations = do
+createSQLiteStore :: FilePath -> Int -> [Migration] -> IO SQLiteStore
+createSQLiteStore dbFilePath poolSize migrations = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing False dbDir
   st <- connectSQLiteStore dbFilePath poolSize
   checkThreadsafe st
-  migrateSchema st migrations yesToMigrations
+  migrateSchema st migrations
   pure st
 
 checkThreadsafe :: SQLiteStore -> IO ()
@@ -96,16 +94,15 @@ checkThreadsafe st = withConnection st $ \db -> do
     Nothing -> putStrLn "Warning: SQLite THREADSAFE compile option not found"
     _ -> return ()
 
-migrateSchema :: SQLiteStore -> [Migration] -> Bool -> IO ()
-migrateSchema st migrations yesToMigrations = withConnection st $ \db -> do
+migrateSchema :: SQLiteStore -> [Migration] -> IO ()
+migrateSchema st migrations = withConnection st $ \db -> do
   Migrations.initialize db
   Migrations.get db migrations >>= \case
     Left e -> confirmOrExit $ "Database error: " <> e
     Right [] -> pure ()
     Right ms -> do
       unless (dbNew st) $ do
-        unless yesToMigrations $
-          confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
+        confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
         let f = dbFilePath st
         copyFile f (f <> ".bak")
       Migrations.run db ms
@@ -129,25 +126,9 @@ connectSQLiteStore dbFilePath poolSize = do
 connectDB :: FilePath -> IO DB.Connection
 connectDB path = do
   dbConn <- DB.open path
-  DB.execute_ dbConn "PRAGMA foreign_keys = ON;"
-  -- DB.execute_ dbConn "PRAGMA trusted_schema = OFF;"
-  DB.execute_ dbConn "PRAGMA secure_delete = ON;"
-  DB.execute_ dbConn "PRAGMA auto_vacuum = FULL;"
-  -- _printPragmas dbConn path
+  DB.execute_ dbConn "PRAGMA foreign_keys = ON; PRAGMA journal_mode = WAL;"
   pure dbConn
 
-_printPragmas :: DB.Connection -> FilePath -> IO ()
-_printPragmas db path = do
-  foreign_keys <- DB.query_ db "PRAGMA foreign_keys;" :: IO [[Int]]
-  print $ path <> " foreign_keys: " <> show foreign_keys
-  -- when run via sqlite-simple query for trusted_schema seems to return empty list
-  trusted_schema <- DB.query_ db "PRAGMA trusted_schema;" :: IO [[Int]]
-  print $ path <> " trusted_schema: " <> show trusted_schema
-  secure_delete <- DB.query_ db "PRAGMA secure_delete;" :: IO [[Int]]
-  print $ path <> " secure_delete: " <> show secure_delete
-  auto_vacuum <- DB.query_ db "PRAGMA auto_vacuum;" :: IO [[Int]]
-  print $ path <> " auto_vacuum: " <> show auto_vacuum
-
 checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
 checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
 
@@ -208,7 +189,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
       getConn_ db connId
 
   getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn
-  getRcvConn st ProtocolServer {host, port} rcvId =
+  getRcvConn st SMPServer {host, port} rcvId =
     liftIOEither . withTransaction st $ \db ->
       DB.queryNamed
         db
@@ -253,7 +234,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         _ -> pure $ Left SEConnNotFound
 
   setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
-  setRcvQueueStatus st RcvQueue {rcvId, server = ProtocolServer {host, port}} status =
+  setRcvQueueStatus st RcvQueue {rcvId, server = SMPServer {host, port}} status =
     -- ? throw error if queue does not exist?
     liftIO . withTransaction st $ \db ->
       DB.executeNamed
@@ -266,7 +247,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
 
   setRcvQueueConfirmedE2E :: SQLiteStore -> RcvQueue -> C.DhSecretX25519 -> m ()
-  setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret =
+  setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eDhSecret =
     liftIO . withTransaction st $ \db ->
       DB.executeNamed
         db
@@ -284,7 +265,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         ]
 
   setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
-  setSndQueueStatus st SndQueue {sndId, server = ProtocolServer {host, port}} status =
+  setSndQueueStatus st SndQueue {sndId, server = SMPServer {host, port}} status =
     -- ? throw error if queue does not exist?
     liftIO . withTransaction st $ \db ->
       DB.executeNamed
@@ -459,7 +440,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
       insertSndMsgDetails_ db connId sndMsgData
       updateHashSnd_ db connId sndMsgData
 
-  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
+  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
   getPendingMsgData st connId msgId =
     liftIOEither . withTransaction st $ \db -> runExceptT $ do
       rq_ <- liftIO $ getRcvQueueByConnId_ db connId
@@ -566,75 +547,6 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
             forM_ (M.assocs mks) $ \(msgN, mk) ->
               DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
 
-  createNtfToken :: SQLiteStore -> NtfToken -> m ()
-  createNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction} =
-    liftIO . withTransaction st $ \db -> do
-      upsertNtfServer_ db srv
-      DB.execute
-        db
-        [sql|
-          INSERT INTO ntf_tokens
-            (provider, device_token, ntf_host, ntf_port, tkn_id, tkn_pub_key, tkn_priv_key, tkn_pub_dh_key, tkn_priv_dh_key, tkn_dh_secret, tkn_status, tkn_action) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
-        |]
-        (provider, token, host, port, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction)
-
-  getDeviceNtfToken :: SQLiteStore -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
-  getDeviceNtfToken st t =
-    liftIO . withTransaction st $ \db -> do
-      tokens <-
-        map ntfToken
-          <$> DB.query_
-            db
-            [sql|
-              SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
-                t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, t.tkn_status, t.tkn_action
-              FROM ntf_tokens t
-              JOIN ntf_servers s USING (ntf_host, ntf_port)
-            |]
-      pure . first listToMaybe $ partition ((t ==) . deviceToken) tokens
-    where
-      ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction)) =
-        let ntfServer = ProtocolServer {host, port, keyHash}
-            ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
-         in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction}
-
-  updateNtfTokenRegistration :: SQLiteStore -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
-  updateNtfTokenRegistration st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret =
-    liftIO . withTransaction st $ \db -> do
-      updatedAt <- getCurrentTime
-      DB.execute
-        db
-        [sql|
-          UPDATE ntf_tokens
-          SET tkn_id = ?, tkn_dh_secret = ?, tkn_status = ?, tkn_action = ?, updated_at = ?
-          WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
-        |]
-        (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
-
-  updateNtfToken :: SQLiteStore -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
-  updateNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction =
-    liftIO . withTransaction st $ \db -> do
-      updatedAt <- getCurrentTime
-      DB.execute
-        db
-        [sql|
-          UPDATE ntf_tokens
-          SET tkn_status = ?, tkn_action = ?, updated_at = ?
-          WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
-        |]
-        (tknStatus, tknAction, updatedAt, provider, token, host, port)
-
-  removeNtfToken :: SQLiteStore -> NtfToken -> m ()
-  removeNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} =
-    liftIO . withTransaction st $ \db ->
-      DB.execute
-        db
-        [sql|
-          DELETE FROM ntf_tokens
-          WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
-        |]
-        (provider, token, host, port)
-
 -- * Auxiliary helpers
 
 instance ToField QueueStatus where toField = toField . serializeQueueStatus
@@ -653,9 +565,9 @@ instance ToField InternalId where toField (InternalId x) = toField x
 
 instance FromField InternalId where fromField x = InternalId <$> fromField x
 
-instance ToField AgentMessageType where toField = toField . smpEncode
+instance ToField AMsgType where toField = toField . smpEncode
 
-instance FromField AgentMessageType where fromField = blobFieldParser smpP
+instance FromField AMsgType where fromField = blobFieldParser smpP
 
 instance ToField MsgIntegrity where toField = toField . strEncode
 
@@ -681,6 +593,14 @@ instance ToField (SConnectionMode c) where toField = toField . connMode
 
 instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT
 
+fromTextField_ :: (E.Typeable a) => (Text -> Maybe a) -> Field -> Ok a
+fromTextField_ fromText = \case
+  f@(Field (SQLText t) _) ->
+    case fromText t of
+      Just x -> Ok x
+      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
+  f -> returnError ConversionFailed f "expecting SQLText column type"
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -719,7 +639,7 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
 -- * Server upsert helper
 
 upsertServer_ :: DB.Connection -> SMPServer -> IO ()
-upsertServer_ dbConn ProtocolServer {host, port, keyHash} = do
+upsertServer_ dbConn SMPServer {host, port, keyHash} = do
   DB.executeNamed
     dbConn
     [sql|
@@ -731,42 +651,50 @@ upsertServer_ dbConn ProtocolServer {host, port, keyHash} = do
     |]
     [":host" := host, ":port" := port, ":key_hash" := keyHash]
 
-upsertNtfServer_ :: DB.Connection -> NtfServer -> IO ()
-upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
-  DB.executeNamed
-    db
-    [sql|
-      INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (:host,:port,:key_hash)
-      ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET
-        ntf_host=excluded.ntf_host,
-        ntf_port=excluded.ntf_port,
-        ntf_key_hash=excluded.ntf_key_hash;
-    |]
-    [":host" := host, ":port" := port, ":key_hash" := keyHash]
-
 -- * createRcvConn helpers
 
 insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
 insertRcvQueue_ dbConn connId RcvQueue {..} = do
-  DB.execute
+  DB.executeNamed
     dbConn
     [sql|
       INSERT INTO rcv_queues
-        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status) VALUES (?,?,?,?,?,?,?,?,?,?);
+        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status)
+      VALUES
+        (:host,:port,:rcv_id,:conn_id,:rcv_private_key,:rcv_dh_secret,:e2e_priv_key,:e2e_dh_secret,:snd_id,:status);
     |]
-    (host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
+    [ ":host" := host server,
+      ":port" := port server,
+      ":rcv_id" := rcvId,
+      ":conn_id" := connId,
+      ":rcv_private_key" := rcvPrivateKey,
+      ":rcv_dh_secret" := rcvDhSecret,
+      ":e2e_priv_key" := e2ePrivKey,
+      ":e2e_dh_secret" := e2eDhSecret,
+      ":snd_id" := sndId,
+      ":status" := status
+    ]
 
 -- * createSndConn helpers
 
 insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
 insertSndQueue_ dbConn connId SndQueue {..} = do
-  DB.execute
+  DB.executeNamed
     dbConn
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status) VALUES (?,?,?,?,?, ?,?, ?,?);
+        ( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)
+      VALUES
+        (:host,:port,:snd_id,:conn_id,:snd_private_key,:e2e_dh_secret,:status);
     |]
-    (host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
+    [ ":host" := host server,
+      ":port" := port server,
+      ":snd_id" := sndId,
+      ":conn_id" := connId,
+      ":snd_private_key" := sndPrivateKey,
+      ":e2e_dh_secret" := e2eDhSecret,
+      ":status" := status
+    ]
 
 -- * getConn helpers
 
@@ -817,16 +745,16 @@ getSndQueueByConnId_ dbConn connId =
     <$> DB.query
       dbConn
       [sql|
-        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status
+        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
         FROM snd_queues q
         INNER JOIN servers s ON q.host = s.host AND q.port = s.port
         WHERE q.conn_id = ?;
       |]
       (Only connId)
   where
-    sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
+    sndQueue [(keyHash, host, port, sndId, sndPrivateKey, e2eDhSecret, status)] =
       let server = SMPServer host port keyHash
-       in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
+       in Just SndQueue {server, sndId, sndPrivateKey, e2eDhSecret, status}
     sndQueue _ = Nothing
 
 -- * updateRcvIds helpers

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

@@ -25,17 +25,13 @@ import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
 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
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
 
 schemaMigrations :: [(String, Query)]
 schemaMigrations =
-  [ ("20220101_initial", m20220101_initial),
-    ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
-    ("20220322_notifications", m20220322_notifications)
+  [ ("20220101_initial", m20220101_initial)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -1,13 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220301_snd_queue_keys :: Query
-m20220301_snd_queue_keys =
-  [sql|
-ALTER TABLE snd_queues ADD COLUMN snd_public_key BLOB;
-ALTER TABLE snd_queues ADD COLUMN e2e_pub_key BLOB;
-|]

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

@@ -1,39 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220322_notifications :: Query
-m20220322_notifications =
-  [sql|
-CREATE TABLE ntf_servers (
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  created_at TEXT NOT NULL DEFAULT (datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
-  PRIMARY KEY (ntf_host, ntf_port)
-) WITHOUT ROWID;
-
-CREATE TABLE ntf_tokens (
-  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,
-  tkn_id BLOB, -- token ID assigned by notifications server
-  tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands (used by server, for repeat registraions)
-  tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
-  tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key (for repeat registraions)
-  tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key (for repeat registraions)
-  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')), -- 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;
-|]

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

@@ -1,38 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220404_ntf_subscriptions_draft :: Query
-m20220404_ntf_subscriptions_draft =
-  [sql|
-ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
-
-ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
-
-ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
-
-CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
-
-CREATE TABLE ntf_subscriptions (
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_sub_id BLOB NOT NULL,
-  ntf_sub_status TEXT NOT NULL, -- new, created, active, pending, error_auth
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: create / check / token / delete
-  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
-  ntf_token TEXT NOT NULL, -- or BLOB?
-  smp_host TEXT NOT NULL,
-  smp_port TEXT NOT NULL,
-  smp_ntf_id BLOB NOT NULL,
-  created_at TEXT NOT NULL,
-  updated_at TEXT NOT NULL, -- this is to check subscription status periodically to know when it was last checked
-  PRIMARY KEY (ntf_host, ntf_port, ntf_sub_id),
-  FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
-    ON DELETE RESTRICT ON UPDATE CASCADE,
-  FOREIGN KEY (smp_host, smp_port, smp_ntf_id) REFERENCES rcv_queues (host, port, ntf_id)
-    ON DELETE RESTRICT ON UPDATE CASCADE
-) WITHOUT ROWID;
-|]

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

@@ -1,161 +0,0 @@
-CREATE TABLE migrations(
-  name TEXT NOT NULL,
-  ts TEXT NOT NULL,
-  PRIMARY KEY(name)
-);
-CREATE TABLE servers(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  key_hash BLOB NOT NULL,
-  PRIMARY KEY(host, port)
-) WITHOUT ROWID;
-CREATE TABLE connections(
-  conn_id BLOB NOT NULL PRIMARY KEY,
-  conn_mode TEXT NOT NULL,
-  last_internal_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',
-  last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
-  smp_agent_version INTEGER NOT NULL DEFAULT 1
-) WITHOUT ROWID;
-CREATE TABLE rcv_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  rcv_id BLOB NOT NULL,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  rcv_private_key BLOB NOT NULL,
-  rcv_dh_secret BLOB NOT NULL,
-  e2e_priv_key BLOB NOT NULL,
-  e2e_dh_secret BLOB,
-  snd_id BLOB NOT NULL,
-  snd_key BLOB,
-  status TEXT NOT NULL,
-  smp_server_version INTEGER NOT NULL DEFAULT 1,
-  smp_client_version INTEGER,
-  PRIMARY KEY(host, port, rcv_id),
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE,
-  UNIQUE(host, port, snd_id)
-) WITHOUT ROWID;
-CREATE TABLE snd_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  snd_id BLOB NOT NULL,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_private_key BLOB NOT NULL,
-  e2e_dh_secret BLOB NOT NULL,
-  status TEXT NOT NULL,
-  smp_server_version INTEGER NOT NULL DEFAULT 1,
-  smp_client_version INTEGER NOT NULL DEFAULT 1,
-  snd_public_key BLOB,
-  e2e_pub_key BLOB,
-  PRIMARY KEY(host, port, snd_id),
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE
-) WITHOUT ROWID;
-CREATE TABLE messages(
-  conn_id BLOB NOT NULL REFERENCES connections(conn_id)
-  ON DELETE CASCADE,
-  internal_id INTEGER NOT NULL,
-  internal_ts TEXT NOT NULL,
-  internal_rcv_id INTEGER,
-  internal_snd_id INTEGER,
-  msg_type BLOB NOT NULL, --(H)ELLO,(R)EPLY,(D)ELETE. Should SMP confirmation be saved too?
-  msg_body BLOB NOT NULL DEFAULT x'',
-  PRIMARY KEY(conn_id, internal_id),
-  FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
-  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
-  FOREIGN KEY(conn_id, internal_snd_id) REFERENCES snd_messages
-  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-) WITHOUT ROWID;
-CREATE TABLE rcv_messages(
-  conn_id BLOB NOT NULL,
-  internal_rcv_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  external_snd_id INTEGER NOT NULL,
-  broker_id BLOB NOT NULL,
-  broker_ts TEXT NOT NULL,
-  internal_hash BLOB NOT NULL,
-  external_prev_snd_hash BLOB NOT NULL,
-  integrity BLOB NOT NULL,
-  PRIMARY KEY(conn_id, internal_rcv_id),
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
-  ON DELETE CASCADE
-) WITHOUT ROWID;
-CREATE TABLE snd_messages(
-  conn_id BLOB NOT NULL,
-  internal_snd_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  internal_hash BLOB NOT NULL,
-  previous_msg_hash BLOB NOT NULL DEFAULT x'',
-  PRIMARY KEY(conn_id, internal_snd_id),
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
-  ON DELETE CASCADE
-) WITHOUT ROWID;
-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, -- 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'))
-) WITHOUT ROWID;
-CREATE TABLE conn_invitations(
-  invitation_id BLOB NOT NULL PRIMARY KEY,
-  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  cr_invitation BLOB NOT NULL,
-  recipient_conn_info BLOB NOT NULL,
-  accepted INTEGER NOT NULL DEFAULT 0,
-  own_conn_info BLOB,
-  created_at TEXT NOT NULL DEFAULT(datetime('now'))
-) WITHOUT ROWID;
-CREATE TABLE ratchets(
-  conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections
-  ON DELETE CASCADE,
-  -- x3dh keys are not saved on the sending side(the side accepting the connection)
-  x3dh_priv_key_1 BLOB,
-  x3dh_priv_key_2 BLOB,
-  -- ratchet is initially empty on the receiving side(the side offering the connection)
-  ratchet_state BLOB,
-  e2e_version INTEGER NOT NULL DEFAULT 1
-) WITHOUT ROWID;
-CREATE TABLE skipped_messages(
-  skipped_message_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES ratchets
-  ON DELETE CASCADE,
-  header_key BLOB NOT NULL,
-  msg_n INTEGER NOT NULL,
-  msg_key BLOB NOT NULL
-);
-CREATE TABLE ntf_servers(
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
-  PRIMARY KEY(ntf_host, ntf_port)
-) WITHOUT ROWID;
-CREATE TABLE ntf_tokens(
-  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,
-  tkn_id BLOB, -- token ID assigned by notifications server
-  tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands(used by server, for repeat registraions)
-tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
-tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key(for repeat registraions)
-tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key(for repeat registraions)
-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')), -- 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;

src/Simplex/Messaging/Client.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -24,10 +23,9 @@
 -- 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 (sessionId),
     SMPClient,
-    getProtocolClient,
-    closeProtocolClient,
+    getSMPClient,
+    closeSMPClient,
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -39,13 +37,13 @@ module Simplex.Messaging.Client
     ackSMPMessage,
     suspendSMPQueue,
     deleteSMPQueue,
-    sendProtocolCommand,
+    sendSMPCommand,
 
     -- * Supporting types and client configuration
-    ProtocolClientError (..),
-    ProtocolClientConfig (..),
-    defaultClientConfig,
-    ServerTransmission,
+    SMPClientError (..),
+    SMPClientConfig (..),
+    smpDefaultConfig,
+    SMPServerTransmission,
   )
 where
 
@@ -58,96 +56,92 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
-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.Protocol
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake)
 import Simplex.Messaging.Transport.Client (runTransportClient)
-import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
 import System.Timeout (timeout)
 
 -- | 'SMPClient' is a handle used to send commands to a specific SMP server.
 --
+-- The only exported selector is blockSize that is negotiated
+-- with the server during the TCP transport handshake.
+--
 -- Use 'getSMPClient' to connect to an SMP server and create a client handle.
-data ProtocolClient msg = ProtocolClient
+data SMPClient = SMPClient
   { action :: Async (),
     connected :: TVar Bool,
-    sessionId :: SessionId,
-    protocolServer :: ProtocolServer,
+    sessionId :: ByteString,
+    smpServer :: SMPServer,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
-    sentCommands :: TMap CorrId (Request msg),
+    sentCommands :: TVar (Map CorrId Request),
     sndQ :: TBQueue SentRawTransmission,
-    rcvQ :: TBQueue (SignedTransmission msg),
-    msgQ :: Maybe (TBQueue (ServerTransmission msg))
+    rcvQ :: TBQueue (SignedTransmission BrokerMsg),
+    msgQ :: TBQueue SMPServerTransmission
   }
 
-type SMPClient = ProtocolClient SMP.BrokerMsg
-
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtocolServer, SessionId, QueueId, msg)
+type SMPServerTransmission = (SMPServer, RecipientId, BrokerMsg)
 
--- | protocol client configuration.
-data ProtocolClientConfig = ProtocolClientConfig
+-- | SMP client configuration.
+data SMPClientConfig = SMPClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
-    -- | default server port if port is not specified in ProtocolServer
+    -- | default SMP server port if port is not specified in SMPServer
     defaultTransport :: (ServiceName, ATransport),
     -- | 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
   }
 
--- | Default protocol client configuration.
-defaultClientConfig :: ProtocolClientConfig
-defaultClientConfig =
-  ProtocolClientConfig
-    { qSize = 64,
-      defaultTransport = ("443", transport @TLS),
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPing = 600_000_000 -- 10min
+-- | Default SMP client configuration.
+smpDefaultConfig :: SMPClientConfig
+smpDefaultConfig =
+  SMPClientConfig
+    { qSize = 16,
+      defaultTransport = ("5223", transport @TLS),
+      tcpTimeout = 4_000_000,
+      smpPing = 30_000_000
     }
 
-data Request msg = Request
+data Request = Request
   { queueId :: QueueId,
-    responseVar :: TMVar (Response msg)
+    responseVar :: TMVar Response
   }
 
-type Response msg = Either ProtocolClientError msg
+type Response = Either SMPClientError BrokerMsg
 
--- | Connects to 'ProtocolServer' using passed client configuration
+-- | Connects to 'SMPServer' 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 => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
-  (atomically mkProtocolClient >>= runClient useTransport)
-    `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
+getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
+getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =
+  atomically mkSMPClient >>= runClient useTransport
   where
-    mkProtocolClient :: STM (ProtocolClient msg)
-    mkProtocolClient = do
+    mkSMPClient :: STM SMPClient
+    mkSMPClient = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
-      sentCommands <- TM.empty
+      sentCommands <- newTVar M.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        ProtocolClient
+        SMPClient
           { action = undefined,
             sessionId = undefined,
             connected,
-            protocolServer,
+            smpServer,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -156,104 +150,101 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
     runClient (port', ATransport t) c = do
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
-            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
+          runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)
+            `finally` atomically (putTMVar thVar $ Left SMPNetworkError)
       th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of
         Just (Right THandle {sessionId}) -> Right c {action, sessionId}
         Just (Left e) -> Left e
-        Nothing -> Left PCENetworkError
+        Nothing -> Left SMPNetworkError
 
     useTransport :: (ServiceName, ATransport)
-    useTransport = case port protocolServer of
+    useTransport = case port smpServer of
       "" -> defaultTransport cfg
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
+    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()
     client _ c thVar h =
-      runExceptT (protocolClientHandshake @msg h $ keyHash protocolServer) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
+      runExceptT (clientHandshake h $ keyHash smpServer) >>= \case
+        Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
         Right th@THandle {sessionId} -> do
           atomically $ do
             writeTVar (connected c) True
             putTMVar thVar $ Right th
-          let c' = c {sessionId} :: ProtocolClient msg
-          -- TODO remove ping if 0 is passed (or Nothing?)
+          let c' = c {sessionId} :: SMPClient
           raceAny_ [send c' th, process c', receive c' th, ping c']
             `finally` disconnected
 
-    send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    send :: Transport c => SMPClient -> THandle c -> IO ()
+    send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-    receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
+    receive :: Transport c => SMPClient -> THandle c -> IO ()
+    receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
-    ping :: ProtocolClient msg -> IO ()
+    ping :: SMPClient -> IO ()
     ping c = forever $ do
       threadDelay smpPing
-      runExceptT $ sendProtocolCommand c Nothing "" protocolPing
+      runExceptT $ sendSMPCommand c Nothing "" PING
 
-    process :: ProtocolClient msg -> IO ()
-    process ProtocolClient {sessionId, rcvQ, sentCommands} = forever $ do
+    process :: SMPClient -> IO ()
+    process SMPClient {rcvQ, sentCommands} = forever $ do
       (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
       if B.null $ bs corrId
         then sendMsg qId respOrErr
         else do
-          atomically (TM.lookup corrId sentCommands) >>= \case
+          cs <- readTVarIO sentCommands
+          case M.lookup corrId cs of
             Nothing -> sendMsg qId respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
-              TM.delete corrId sentCommands
+              modifyTVar sentCommands $ M.delete corrId
               putTMVar responseVar $
                 if queueId == qId
                   then case respOrErr of
-                    Left e -> Left $ PCEResponseError e
-                    Right r -> case protocolError r of
-                      Just e -> Left $ PCEProtocolError e
-                      _ -> Right r
-                  else Left PCEUnexpectedResponse
-      where
-        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 ()
+                    Left e -> Left $ SMPResponseError e
+                    Right (ERR e) -> Left $ SMPServerError e
+                    Right r -> Right r
+                  else Left SMPUnexpectedResponse
 
--- | Disconnects client from the server and terminates client threads.
-closeProtocolClient :: ProtocolClient msg -> IO ()
-closeProtocolClient = uninterruptibleCancel . action
+    sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO ()
+    sendMsg qId = \case
+      Right cmd -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)
+      -- TODO send everything else to errQ and log in agent
+      _ -> return ()
+
+-- | Disconnects SMP client from the server and terminates client threads.
+closeSMPClient :: SMPClient -> IO ()
+closeSMPClient = uninterruptibleCancel . action
 
 -- | SMP client error type.
-data ProtocolClientError
+data SMPClientError
   = -- | Correctly parsed SMP server ERR response.
     -- This error is forwarded to the agent client as `ERR SMP err`.
-    PCEProtocolError ErrorType
+    SMPServerError ErrorType
   | -- | Invalid server response that failed to parse.
     -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
-    PCEResponseError ErrorType
+    SMPResponseError ErrorType
   | -- | Different response from what is expected to a certain SMP command,
     -- 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
+    SMPUnexpectedResponse
   | -- | Used for TCP connection and command response timeouts.
     -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
-    PCEResponseTimeout
+    SMPResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
-    PCENetworkError
+    SMPNetworkError
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
-    PCETransportError TransportError
+    SMPTransportError TransportError
   | -- | Error when cryptographically "signing" the command.
-    PCESignatureError C.CryptoError
-  | -- | IO Error
-    PCEIOError IOException
+    SMPSignatureError C.CryptoError
   deriving (Eq, Show, Exception)
 
 -- | Create a new SMP queue.
@@ -264,95 +255,92 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
-  ExceptT ProtocolClientError IO QueueIdsKeys
+  ExceptT SMPClientError IO QueueIdsKeys
 createSMPQueue c rpKey rKey dhKey =
   sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
     IDS qik -> pure qik
-    _ -> throwE PCEUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
 -- | 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@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
+subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
     cmd@MSG {} ->
-      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
-    _ -> throwE PCEUnexpectedResponse
+      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT ProtocolClientError IO ()
+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications = okSMPCommand NSUB
 
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
-secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
+secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
 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 -> ExceptT ProtocolClientError IO NotifierId
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId
 enableSMPQueueNotifications c rpKey rId notifierKey =
   sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
     NID nId -> pure nId
-    _ -> throwE PCEUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT ProtocolClientError IO ()
+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
 sendSMPMessage c spKey sId msg =
   sendSMPCommand c spKey sId (SEND msg) >>= \case
     OK -> pure ()
-    _ -> throwE PCEUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
 -- | 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 -> ExceptT ProtocolClientError IO ()
-ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
+ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId ACK >>= \case
     OK -> return ()
     cmd@MSG {} ->
-      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
-    _ -> throwE PCEUnexpectedResponse
+      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Irreversibly suspend SMP queue.
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 suspendSMPQueue = okSMPCommand OFF
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
-    _ -> throwE PCEUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
 -- | 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 Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
+-- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient)
+sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
+sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
   corrId <- lift_ getNextCorrId
   t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
   ExceptT $ sendRecv corrId t
   where
-    lift_ :: STM a -> ExceptT ProtocolClientError IO a
+    lift_ :: STM a -> ExceptT SMPClientError IO a
     lift_ action = ExceptT $ Right <$> atomically action
 
     getNextCorrId :: STM CorrId
@@ -360,22 +348,22 @@ sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId,
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
 
-    signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
+    signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission
     signTransmission t = case pKey of
       Nothing -> return (Nothing, t)
       Just pk -> do
-        sig <- liftError PCESignatureError $ C.sign pk t
+        sig <- liftError SMPSignatureError $ C.sign pk t
         return (Just sig, t)
 
     -- two separate "atomically" needed to avoid blocking
-    sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
+    sendRecv :: CorrId -> SentRawTransmission -> IO Response
     sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
       where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
+        withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
 
-    send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
+    send :: CorrId -> SentRawTransmission -> STM (TMVar Response)
     send corrId t = do
       r <- newEmptyTMVar
-      TM.insert corrId (Request qId r) sentCommands
+      modifyTVar sentCommands . M.insert corrId $ Request qId r
       writeTBQueue sndQ t
       return r

src/Simplex/Messaging/Client/Agent.hs

@@ -1,301 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Simplex.Messaging.Client.Agent where
-
-import Control.Concurrent (forkIO)
-import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Logger.Simple
-import Control.Monad.Except
-import Control.Monad.IO.Unlift
-import Control.Monad.Trans.Except
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import Data.Text.Encoding
-import Numeric.Natural
-import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Client
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (catchAll_, tryE, whenM, ($>>=))
-import System.Timeout (timeout)
-import UnliftIO (async, forConcurrently_)
-import UnliftIO.Exception (Exception)
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-
-type SMPClientVar = TMVar (Either ProtocolClientError SMPClient)
-
-data SMPClientAgentEvent
-  = CAConnected SMPServer
-  | CADisconnected SMPServer (Set SMPSub)
-  | CAReconnected SMPServer
-  | CAResubscribed SMPServer SMPSub
-  | CASubError SMPServer SMPSub ProtocolClientError
-
-data SMPSubParty = SPRecipient | SPNotifier
-  deriving (Eq, Ord)
-
-type SMPSub = (SMPSubParty, QueueId)
-
--- type SMPServerSub = (SMPServer, SMPSub)
-
-data SMPClientAgentConfig = SMPClientAgentConfig
-  { smpCfg :: ProtocolClientConfig,
-    reconnectInterval :: RetryInterval,
-    msgQSize :: Natural,
-    agentQSize :: Natural
-  }
-
-defaultSMPClientAgentConfig :: SMPClientAgentConfig
-defaultSMPClientAgentConfig =
-  SMPClientAgentConfig
-    { smpCfg = defaultClientConfig,
-      reconnectInterval =
-        RetryInterval
-          { initialInterval = second,
-            increaseAfter = 10 * second,
-            maxInterval = 10 * second
-          },
-      msgQSize = 64,
-      agentQSize = 64
-    }
-  where
-    second = 1000000
-
-data SMPClientAgent = SMPClientAgent
-  { agentCfg :: SMPClientAgentConfig,
-    msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    agentQ :: TBQueue SMPClientAgentEvent,
-    smpClients :: TMap SMPServer SMPClientVar,
-    srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
-    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
-    reconnections :: TVar [Async ()],
-    asyncClients :: TVar [Async ()]
-  }
-
-newtype InternalException e = InternalException {unInternalException :: e}
-  deriving (Eq, Show)
-
-instance Exception e => Exception (InternalException e)
-
-instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
-  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
-  withRunInIO exceptToIO =
-    withExceptT unInternalException . ExceptT . E.try $
-      withRunInIO $ \run ->
-        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
-
-newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent
-newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
-  msgQ <- newTBQueue msgQSize
-  agentQ <- newTBQueue agentQSize
-  smpClients <- TM.empty
-  srvSubs <- TM.empty
-  pendingSrvSubs <- TM.empty
-  reconnections <- newTVar []
-  asyncClients <- newTVar []
-  pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
-
-getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT ProtocolClientError IO SMPClient
-getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
-  atomically getClientVar >>= either newSMPClient waitForSMPClient
-  where
-    getClientVar :: STM (Either SMPClientVar SMPClientVar)
-    getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
-
-    newClientVar :: STM SMPClientVar
-    newClientVar = do
-      smpVar <- newEmptyTMVar
-      TM.insert srv smpVar smpClients
-      pure smpVar
-
-    waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
-    waitForSMPClient smpVar = do
-      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
-        Nothing -> Left PCEResponseTimeout
-
-    newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
-    newSMPClient smpVar = tryConnectClient pure tryConnectAsync
-      where
-        tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
-        tryConnectClient successAction retryAction =
-          tryE connectClient >>= \r -> case r of
-            Right smp -> do
-              logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-              atomically $ putTMVar smpVar r
-              successAction smp
-            Left e -> do
-              if e == PCENetworkError || e == PCEResponseTimeout
-                then retryAction
-                else atomically $ do
-                  putTMVar smpVar (Left e)
-                  TM.delete srv smpClients
-              throwE e
-        tryConnectAsync :: ExceptT ProtocolClientError IO ()
-        tryConnectAsync = do
-          a <- async connectAsync
-          atomically $ modifyTVar' (asyncClients ca) (a :)
-        connectAsync :: ExceptT ProtocolClientError IO ()
-        connectAsync =
-          withRetryInterval (reconnectInterval agentCfg) $ \loop ->
-            void $ tryConnectClient (const reconnectClient) loop
-
-    connectClient :: ExceptT ProtocolClientError IO SMPClient
-    connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
-
-    clientDisconnected :: IO ()
-    clientDisconnected = do
-      removeClientAndSubs >>= (`forM_` serverDown)
-      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
-
-    removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
-      TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
-      where
-        updateSubs sVar = do
-          ss <- readTVar sVar
-          addPendingSubs sVar ss
-          pure ss
-
-        addPendingSubs sVar ss = do
-          let ps = pendingSrvSubs ca
-          TM.lookup srv ps >>= \case
-            Just v -> TM.union ss v
-            _ -> TM.insert srv sVar ps
-
-    serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
-    serverDown ss = unless (M.null ss) . void . runExceptT $ do
-      notify . CADisconnected srv $ M.keysSet ss
-      reconnectServer
-
-    reconnectServer :: ExceptT ProtocolClientError IO ()
-    reconnectServer = do
-      a <- async tryReconnectClient
-      atomically $ modifyTVar' (reconnections ca) (a :)
-
-    tryReconnectClient :: ExceptT ProtocolClientError IO ()
-    tryReconnectClient = do
-      withRetryInterval (reconnectInterval agentCfg) $ \loop ->
-        reconnectClient `catchE` const loop
-
-    reconnectClient :: ExceptT ProtocolClientError IO ()
-    reconnectClient = do
-      withSMP ca srv $ \smp -> do
-        notify $ CAReconnected srv
-        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
-        forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          whenM (atomically $ hasSub (srvSubs ca) srv s) $
-            subscribe_ smp sub `catchE` handleError s
-      where
-        subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
-        subscribe_ smp sub@(s, _) = do
-          smpSubscribe smp sub
-          atomically $ addSubscription ca srv sub
-          notify $ CAResubscribed srv s
-
-        handleError :: SMPSub -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
-        handleError s = \case
-          e@PCEResponseTimeout -> throwE e
-          e@PCENetworkError -> throwE e
-          e -> do
-            notify $ CASubError srv s e
-            atomically $ removePendingSubscription ca srv s
-
-    notify :: SMPClientAgentEvent -> ExceptT ProtocolClientError IO ()
-    notify evt = atomically $ writeTBQueue (agentQ ca) evt
-
-closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
-closeSMPClientAgent c = liftIO $ do
-  closeSMPServerClients c
-  cancelActions $ reconnections c
-  cancelActions $ asyncClients c
-
-closeSMPServerClients :: SMPClientAgent -> IO ()
-closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
-  where
-    closeClient smpVar =
-      atomically (readTMVar smpVar) >>= \case
-        Right smp -> closeProtocolClient smp `catchAll_` pure ()
-        _ -> pure ()
-
-cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
-
-withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO a
-withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
-  where
-    logSMPError :: ProtocolClientError -> ExceptT ProtocolClientError IO a
-    logSMPError e = do
-      liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
-      throwE e
-
-subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
-subscribeQueue ca srv sub = do
-  atomically $ addPendingSubscription ca srv sub
-  withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
-  where
-    subscribe_ smp = do
-      smpSubscribe smp sub
-      atomically $ addSubscription ca srv sub
-
-    handleError e = do
-      atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
-        removePendingSubscription ca srv $ fst sub
-      throwE e
-
-showServer :: SMPServer -> ByteString
-showServer ProtocolServer {host, 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
-  where
-    subscribe_ = case party of
-      SPRecipient -> subscribeSMPQueue
-      SPNotifier -> subscribeSMPQueueNotifications
-
-addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addSubscription ca srv sub = do
-  addSub_ (srvSubs ca) srv sub
-  removePendingSubscription ca srv $ fst sub
-
-addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addPendingSubscription = addSub_ . pendingSrvSubs
-
-addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addSub_ subs srv (s, key) =
-  TM.lookup srv subs >>= \case
-    Just m -> TM.insert s key m
-    _ -> TM.singleton s key >>= \v -> TM.insert srv v subs
-
-removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removeSubscription = removeSub_ . srvSubs
-
-removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removePendingSubscription = removeSub_ . pendingSrvSubs
-
-removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
-removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
-
-getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
-getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
-
-hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
-hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs

src/Simplex/Messaging/Crypto.hs

@@ -52,7 +52,6 @@ module Simplex.Messaging.Crypto
     CryptoPublicKey (..),
     CryptoPrivateKey (..),
     KeyPair,
-    ASignatureKeyPair,
     DhSecret (..),
     DhSecretX25519,
     ADhSecret (..),
@@ -104,10 +103,6 @@ module Simplex.Messaging.Crypto
     cbDecrypt,
     cbNonce,
     randomCbNonce,
-    pseudoRandomCbNonce,
-
-    -- * pseudo-random bytes
-    pseudoRandomBytes,
 
     -- * SHA256 hash
     sha256Hash,
@@ -121,7 +116,6 @@ module Simplex.Messaging.Crypto
   )
 where
 
-import Control.Concurrent.STM
 import Control.Exception (Exception)
 import Control.Monad.Except
 import Control.Monad.Trans.Except
@@ -135,7 +129,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import qualified Crypto.PubKey.Ed448 as Ed448
-import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate)
+import Crypto.Random (getRandomBytes)
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
 import Data.ASN1.Types
@@ -155,14 +149,20 @@ import Data.String
 import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.X509
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
+import qualified Database.PostgreSQL.Simple as PDB
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.ToField as PT
+import qualified Database.PostgreSQL.Simple.TypeInfo as PTI
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PTIS
+import qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.ToField as ST
 import GHC.TypeLits (ErrorMessage (..), TypeError)
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
+import qualified Database.PostgreSQL.Simple as PDB
 
 -- | Cryptographic algorithms.
 data Algorithm = Ed25519 | Ed448 | X25519 | X448
@@ -290,12 +290,6 @@ instance Eq APrivateSignKey where
 
 deriving instance Show APrivateSignKey
 
-instance Encoding APrivateSignKey where
-  smpEncode = smpEncode . encodePrivKey
-  {-# INLINE smpEncode #-}
-  smpDecode = decodePrivKey
-  {-# INLINE smpDecode #-}
-
 data APublicVerifyKey
   = forall a.
     (AlgorithmI a, SignatureAlgorithm a) =>
@@ -552,33 +546,62 @@ generateKeyPair' = case sAlgorithm @a of
       let k = X448.toPublic pk
        in pure (PublicKeyX448 k, PrivateKeyX448 pk k)
 
-instance ToField APrivateSignKey where toField = toField . encodePrivKey
+instance ST.ToField APrivateSignKey where toField = ST.toField . encodePrivKey
 
-instance ToField APublicVerifyKey where toField = toField . encodePubKey
+instance ST.ToField APublicVerifyKey where toField = ST.toField . encodePubKey
 
-instance ToField APrivateDhKey where toField = toField . encodePrivKey
+instance ST.ToField APrivateDhKey where toField = ST.toField . encodePrivKey
 
-instance ToField APublicDhKey where toField = toField . encodePubKey
+instance ST.ToField APublicDhKey where toField = ST.toField . encodePubKey
 
-instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . encodePrivKey
+instance AlgorithmI a => ST.ToField (PrivateKey a) where toField = ST.toField . encodePrivKey
 
-instance AlgorithmI a => ToField (PublicKey a) where toField = toField . encodePubKey
+instance AlgorithmI a => ST.ToField (PublicKey a) where toField = ST.toField . encodePubKey
 
-instance ToField (DhSecret a) where toField = toField . dhBytes'
+instance ST.ToField (DhSecret a) where toField = ST.toField . dhBytes'
 
-instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey
+instance SF.FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey
 
-instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey
+instance SF.FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey
 
-instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey
+instance SF.FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey
 
-instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey
+instance SF.FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey
 
-instance (Typeable a, AlgorithmI a) => FromField (PrivateKey a) where fromField = blobFieldDecoder decodePrivKey
+instance (Typeable a, AlgorithmI a) => SF.FromField (PrivateKey a) where fromField = blobFieldDecoder decodePrivKey
 
-instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField = blobFieldDecoder decodePubKey
+instance (Typeable a, AlgorithmI a) => SF.FromField (PublicKey a) where fromField = blobFieldDecoder decodePubKey
 
-instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode
+instance (Typeable a, AlgorithmI a) => SF.FromField (DhSecret a) where fromField = blobFieldDecoder strDecode
+
+instance PT.ToField APrivateSignKey where toField = PT.toField . encodePrivKey
+
+instance PT.ToField APublicVerifyKey where toField = PT.toField . encodePubKey
+
+instance PT.ToField APrivateDhKey where toField = PT.toField . encodePrivKey
+
+instance PT.ToField APublicDhKey where toField = PT.toField . encodePubKey
+
+instance AlgorithmI a => PT.ToField (PrivateKey a) where toField = PT.toField . encodePrivKey
+
+instance AlgorithmI a => PT.ToField (PublicKey a) where toField = PT.toField . encodePubKey
+
+instance PT.ToField (DhSecret a) where toField = PT.toField . PDB.Binary . dhBytes'
+
+instance PF.FromField APrivateSignKey where fromField = fromByteStringField decodePrivKey
+
+instance PF.FromField APublicVerifyKey where fromField = fromByteStringField decodePubKey
+
+instance PF.FromField APrivateDhKey where fromField = fromByteStringField decodePrivKey
+
+instance PF.FromField APublicDhKey where fromField = fromByteStringField decodePubKey
+
+instance (Typeable a, AlgorithmI a) => PF.FromField (PrivateKey a) where fromField = fromByteStringField decodePrivKey
+
+instance (Typeable a, AlgorithmI a) => PF.FromField (PublicKey a) where fromField = fromByteStringField decodePubKey
+
+-- instance (Typeable a, AlgorithmI a) => PF.FromField (DhSecret a) where fromField = fromByteStringField strDecode
+instance (Typeable a, AlgorithmI a) => PF.FromField (DhSecret a) where fromField x = fromByteStringField strDecode x
 
 instance IsString (Maybe ASignature) where
   fromString = parseString $ decode >=> decodeSignature
@@ -702,9 +725,13 @@ validSignatureSize n =
 newtype Key = Key {unKey :: ByteString}
   deriving (Eq, Ord, Show)
 
-instance ToField Key where toField = toField . unKey
+instance ST.ToField Key where toField = ST.toField . unKey
 
-instance FromField Key where fromField f = Key <$> fromField f
+instance PT.ToField Key where toField = PT.toField . unKey
+
+instance SF.FromField Key where fromField f = Key <$> SF.fromField f
+
+instance PF.FromField Key where fromField f = PF.fromField f
 
 instance ToJSON Key where
   toJSON = strToJSON . unKey
@@ -742,9 +769,27 @@ instance StrEncoding KeyHash where
 instance IsString KeyHash where
   fromString = parseString $ parseAll strP
 
-instance ToField KeyHash where toField = toField . strEncode
+instance ST.ToField KeyHash where toField = ST.toField . strEncode
 
-instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
+instance SF.FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
+
+instance PT.ToField KeyHash where toField = PT.toField . strEncode
+
+-- TODO
+-- instance PF.FromField KeyHash where fromField = blobFieldDecoderPostgres $ parseAll strP
+
+instance PF.FromField KeyHash where fromField = fromByteStringField $ parseAll strP
+
+fromByteStringField :: Typeable a => (ByteString -> Either String a) -> PF.Field -> Maybe ByteString -> PF.Conversion a
+fromByteStringField dec f mdata =
+  if PF.typeOid f /= PTI.typoid PTIS.bytea
+    then PF.returnError PF.Incompatible f ""
+    else case mdata of
+      Nothing -> PF.returnError PF.UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> PF.returnError PF.ConversionFailed f (B.unpack dat)
 
 -- | SHA256 digest.
 sha256Hash :: ByteString -> ByteString
@@ -871,14 +916,6 @@ cbDecrypt secret (CbNonce nonce) packet
 newtype CbNonce = CbNonce {unCbNonce :: ByteString}
   deriving (Show)
 
-instance StrEncoding CbNonce where
-  strEncode (CbNonce s) = strEncode s
-  strP = cbNonce <$> strP
-
-instance ToJSON CbNonce where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
 cbNonce :: ByteString -> CbNonce
 cbNonce s
   | len == 24 = CbNonce s
@@ -890,16 +927,6 @@ cbNonce s
 randomCbNonce :: IO CbNonce
 randomCbNonce = CbNonce <$> getRandomBytes 24
 
-pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
-pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar
-
-pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
-pseudoRandomBytes n gVar = do
-  g <- readTVar gVar
-  let (bytes, g') = randomBytesGenerate n g
-  writeTVar gVar g'
-  return bytes
-
 instance Encoding CbNonce where
   smpEncode = unCbNonce
   smpP = CbNonce <$> A.take 24

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -30,8 +30,12 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Data.Typeable (Typeable)
 import Data.Word (Word32)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.ToField as PT
+import qualified Database.PostgreSQL.Simple.TypeInfo as PTI
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PTIS
+import qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.ToField as ST
 import GHC.Generics
 import Simplex.Messaging.Agent.QueryString
 import Simplex.Messaging.Crypto
@@ -197,13 +201,32 @@ instance ToJSON RatchetKey where
 instance FromJSON RatchetKey where
   parseJSON = fmap RatchetKey . strParseJSON "Key"
 
-instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode
+instance AlgorithmI a => ST.ToField (Ratchet a) where toField = ST.toField . LB.toStrict . J.encode
 
-instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
+instance AlgorithmI a => PT.ToField (Ratchet a) where toField = PT.toField . LB.toStrict . J.encode
 
-instance ToField MessageKey where toField = toField . smpEncode
+instance (AlgorithmI a, Typeable a) => PF.FromField (Ratchet a) where fromField = fromByteStringField J.eitherDecodeStrict'
 
-instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
+instance (AlgorithmI a, Typeable a) => SF.FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
+
+instance ST.ToField MessageKey where toField = ST.toField . smpEncode
+
+instance PT.ToField MessageKey where toField = PT.toField . smpEncode
+
+instance SF.FromField MessageKey where fromField = blobFieldDecoder smpDecode
+
+instance PF.FromField MessageKey where fromField = fromByteStringField smpDecode
+
+fromByteStringField :: Typeable a => (ByteString -> Either String a) -> PF.Field -> Maybe ByteString -> PF.Conversion a
+fromByteStringField dec f mdata =
+  if PF.typeOid f /= PTI.typoid PTIS.bytea
+    then PF.returnError PF.Incompatible f ""
+    else case mdata of
+      Nothing -> PF.returnError PF.UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> PF.returnError PF.ConversionFailed f (B.unpack dat)
 
 -- | Sending ratchet initialization, equivalent to RatchetInitAliceHE in double ratchet spec
 --

src/Simplex/Messaging/Encoding.hs

@@ -141,7 +141,3 @@ instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c,
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
   smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
   smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-
-instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
-  smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
-  smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP

src/Simplex/Messaging/Encoding/String.hs

@@ -2,8 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Encoding.String
-  ( TextEncoding (..),
-    StrEncoding (..),
+  ( StrEncoding (..),
     Str (..),
     strP_,
     strToJSON,
@@ -26,19 +25,12 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
-import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
-import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock.System (SystemTime (..))
 import Data.Word (Word16)
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))
 
-class TextEncoding a where
-  textEncode :: a -> Text
-  textDecode :: Text -> Maybe a
-
 -- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols
 class StrEncoding a where
   {-# MINIMAL strEncode, (strDecode | strP) #-}
@@ -84,14 +76,6 @@ instance StrEncoding Word16 where
   strEncode = B.pack . show
   strP = A.decimal
 
-instance StrEncoding Int64 where
-  strEncode = B.pack . show
-  strP = A.decimal
-
-instance StrEncoding SystemTime where
-  strEncode = strEncode . systemSeconds
-  strP = MkSystemTime <$> strP <*> pure 0
-
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
 strEncodeList = B.intercalate "," . map strEncode

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,132 +0,0 @@
-{-# 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.Word (Word16)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
-import Simplex.Messaging.Client
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (blobFieldDecoder)
-import Simplex.Messaging.Protocol (ProtocolServer)
-
-type NtfServer = ProtocolServer
-
-type NtfClient = ProtocolClient NtfResponse
-
-ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
-ntfRegisterToken c pKey newTkn =
-  sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
-    NRId tknId dhKey -> pure (tknId, dhKey)
-    _ -> throwE PCEUnexpectedResponse
-
-ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
-ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
-
-ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
-ntfCheckToken c pKey tknId =
-  sendNtfCommand c (Just pKey) tknId TCHK >>= \case
-    NRTkn stat -> pure stat
-    _ -> throwE PCEUnexpectedResponse
-
-ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
-ntfDeleteToken = okNtfCommand TDEL
-
-ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
-ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
-
-ntfCreateSubsciption :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO (NtfSubscriptionId, C.PublicKeyX25519)
-ntfCreateSubsciption c pKey newSub =
-  sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
-    NRId subId dhKey -> pure (subId, dhKey)
-    _ -> 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
-    _ -> throwE PCEUnexpectedResponse
-
-ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
-ntfDeleteSubscription = okNtfCommand SDEL
-
--- | Send notification server command
-sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
-sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
-
-okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
-okNtfCommand cmd c pKey entId =
-  sendNtfCommand c (Just pKey) entId cmd >>= \case
-    NROk -> return ()
-    _ -> 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
-    }

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -1,434 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Simplex.Messaging.Notifications.Protocol where
-
-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
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Kind
-import Data.Maybe (isNothing)
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Type.Equality
-import Data.Word (Word16)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
-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 ((<$?>))
-
-data NtfEntity = Token | Subscription
-  deriving (Show)
-
-data SNtfEntity :: NtfEntity -> Type where
-  SToken :: SNtfEntity 'Token
-  SSubscription :: SNtfEntity 'Subscription
-
-instance TestEquality SNtfEntity where
-  testEquality SToken SToken = Just Refl
-  testEquality SSubscription SSubscription = Just Refl
-  testEquality _ _ = Nothing
-
-deriving instance Show (SNtfEntity e)
-
-class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e
-
-instance NtfEntityI 'Token where sNtfEntity = SToken
-
-instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
-
-data NtfCommandTag (e :: NtfEntity) where
-  TNEW_ :: NtfCommandTag 'Token
-  TVFY_ :: NtfCommandTag 'Token
-  TCHK_ :: NtfCommandTag 'Token
-  TDEL_ :: NtfCommandTag 'Token
-  TCRN_ :: NtfCommandTag 'Token
-  SNEW_ :: NtfCommandTag 'Subscription
-  SCHK_ :: NtfCommandTag 'Subscription
-  SDEL_ :: NtfCommandTag 'Subscription
-  PING_ :: NtfCommandTag 'Subscription
-
-deriving instance Show (NtfCommandTag e)
-
-data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)
-
-instance NtfEntityI e => Encoding (NtfCommandTag e) where
-  smpEncode = \case
-    TNEW_ -> "TNEW"
-    TVFY_ -> "TVFY"
-    TCHK_ -> "TCHK"
-    TDEL_ -> "TDEL"
-    TCRN_ -> "TCRN"
-    SNEW_ -> "SNEW"
-    SCHK_ -> "SCHK"
-    SDEL_ -> "SDEL"
-    PING_ -> "PING"
-  smpP = messageTagP
-
-instance Encoding NtfCmdTag where
-  smpEncode (NCT _ t) = smpEncode t
-  smpP = messageTagP
-
-instance ProtocolMsgTag NtfCmdTag where
-  decodeTag = \case
-    "TNEW" -> Just $ NCT SToken TNEW_
-    "TVFY" -> Just $ NCT SToken TVFY_
-    "TCHK" -> Just $ NCT SToken TCHK_
-    "TDEL" -> Just $ NCT SToken TDEL_
-    "TCRN" -> Just $ NCT SToken TCRN_
-    "SNEW" -> Just $ NCT SSubscription SNEW_
-    "SCHK" -> Just $ NCT SSubscription SCHK_
-    "SDEL" -> Just $ NCT SSubscription SDEL_
-    "PING" -> Just $ NCT SSubscription PING_
-    _ -> Nothing
-
-instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
-  decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
-
-newtype NtfRegCode = NtfRegCode ByteString
-  deriving (Eq, Show)
-
-instance Encoding NtfRegCode where
-  smpEncode (NtfRegCode code) = smpEncode code
-  smpP = NtfRegCode <$> smpP
-
-instance StrEncoding NtfRegCode where
-  strEncode (NtfRegCode m) = strEncode m
-  strDecode s = NtfRegCode <$> strDecode s
-  strP = NtfRegCode <$> strP
-
-instance FromJSON NtfRegCode where
-  parseJSON = strParseJSON "NtfRegCode"
-
-instance ToJSON NtfRegCode where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-data NewNtfEntity (e :: NtfEntity) where
-  NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
-  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NewNtfEntity 'Subscription -- NtfTokenId -> C.APublicVerifyKey -> SMPQueueNtf
-
-deriving instance Show (NewNtfEntity e)
-
-data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
-
-instance NtfEntityI e => Encoding (NewNtfEntity e) where
-  smpEncode = \case
-    NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
-    NewNtfSub tknId smpQueue -> smpEncode ('S', tknId, smpQueue)
-  smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
-
-instance Encoding ANewNtfEntity where
-  smpEncode (ANE _ e) = smpEncode e
-  smpP =
-    A.anyChar >>= \case
-      'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
-      'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP)
-      _ -> fail "bad ANewNtfEntity"
-
-instance Protocol NtfResponse where
-  type ProtocolCommand NtfResponse = NtfCmd
-  protocolClientHandshake = ntfClientHandshake
-  protocolPing = NtfCmd SSubscription PING
-  protocolError = \case
-    NRErr e -> Just e
-    _ -> Nothing
-
-data NtfCommand (e :: NtfEntity) where
-  -- | register new device token for notifications
-  TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
-  -- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
-  TVFY :: NtfRegCode -> NtfCommand 'Token
-  -- | check token status
-  TCHK :: 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
-  TCRN :: Word16 -> NtfCommand 'Token
-  -- | create SMP subscription
-  SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
-  -- | check SMP subscription status (response is STAT)
-  SCHK :: NtfCommand 'Subscription
-  -- | delete SMP subscription
-  SDEL :: NtfCommand 'Subscription
-  -- | keep-alive command
-  PING :: NtfCommand 'Subscription
-
-deriving instance Show (NtfCommand e)
-
-data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
-
-deriving instance Show NtfCmd
-
-instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
-  type Tag (NtfCommand e) = NtfCommandTag e
-  encodeProtocol = \case
-    TNEW newTkn -> e (TNEW_, ' ', newTkn)
-    TVFY code -> e (TVFY_, ' ', code)
-    TCHK -> e TCHK_
-    TDEL -> e TDEL_
-    TCRN int -> e (TCRN_, ' ', int)
-    SNEW newSub -> e (SNEW_, ' ', newSub)
-    SCHK -> e SCHK_
-    SDEL -> e SDEL_
-    PING -> e PING_
-    where
-      e :: Encoding a => a -> ByteString
-      e = smpEncode
-
-  protocolP tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP (NCT (sNtfEntity @e) tag)
-
-  checkCredentials (sig, _, entityId, _) cmd = case cmd of
-    -- TNEW and SNEW must have signature but NOT token/subscription IDs
-    TNEW {} -> sigNoEntity
-    SNEW {} -> sigNoEntity
-    PING
-      | isNothing sig && B.null entityId -> Right cmd
-      | otherwise -> Left $ CMD HAS_AUTH
-    -- other client commands must have both signature and entity ID
-    _
-      | isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
-      | otherwise -> Right cmd
-    where
-      sigNoEntity
-        | isNothing sig = Left $ CMD NO_AUTH
-        | not (B.null entityId) = Left $ CMD HAS_AUTH
-        | otherwise = Right cmd
-
-instance ProtocolEncoding NtfCmd where
-  type Tag NtfCmd = NtfCmdTag
-  encodeProtocol (NtfCmd _ c) = encodeProtocol c
-
-  protocolP = \case
-    NCT SToken tag ->
-      NtfCmd SToken <$> case tag of
-        TNEW_ -> TNEW <$> _smpP
-        TVFY_ -> TVFY <$> _smpP
-        TCHK_ -> pure TCHK
-        TDEL_ -> pure TDEL
-        TCRN_ -> TCRN <$> _smpP
-    NCT SSubscription tag ->
-      NtfCmd SSubscription <$> case tag of
-        SNEW_ -> SNEW <$> _smpP
-        SCHK_ -> pure SCHK
-        SDEL_ -> pure SDEL
-        PING_ -> pure PING
-
-  checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
-
-data NtfResponseTag
-  = NRId_
-  | NROk_
-  | NRErr_
-  | NRTkn_
-  | NRSub_
-  | NRPong_
-  deriving (Show)
-
-instance Encoding NtfResponseTag where
-  smpEncode = \case
-    NRId_ -> "ID"
-    NROk_ -> "OK"
-    NRErr_ -> "ERR"
-    NRTkn_ -> "TKN"
-    NRSub_ -> "SUB"
-    NRPong_ -> "PONG"
-  smpP = messageTagP
-
-instance ProtocolMsgTag NtfResponseTag where
-  decodeTag = \case
-    "ID" -> Just NRId_
-    "OK" -> Just NROk_
-    "ERR" -> Just NRErr_
-    "TKN" -> Just NRTkn_
-    "SUB" -> Just NRSub_
-    "PONG" -> Just NRPong_
-    _ -> Nothing
-
-data NtfResponse
-  = NRId NtfEntityId C.PublicKeyX25519
-  | NROk
-  | NRErr ErrorType
-  | NRTkn NtfTknStatus
-  | NRSub NtfSubStatus
-  | NRPong
-  deriving (Show)
-
-instance ProtocolEncoding NtfResponse where
-  type Tag NtfResponse = NtfResponseTag
-  encodeProtocol = \case
-    NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
-    NROk -> e NROk_
-    NRErr err -> e (NRErr_, ' ', err)
-    NRTkn stat -> e (NRTkn_, ' ', stat)
-    NRSub stat -> e (NRSub_, ' ', stat)
-    NRPong -> e NRPong_
-    where
-      e :: Encoding a => a -> ByteString
-      e = smpEncode
-
-  protocolP = \case
-    NRId_ -> NRId <$> _smpP <*> smpP
-    NROk_ -> pure NROk
-    NRErr_ -> NRErr <$> _smpP
-    NRTkn_ -> NRTkn <$> _smpP
-    NRSub_ -> NRSub <$> _smpP
-    NRPong_ -> pure NRPong
-
-  checkCredentials (_, _, entId, _) cmd = case cmd of
-    -- ID response must not have queue ID
-    NRId {} -> noEntity
-    -- ERR response does not always have entity ID
-    NRErr _ -> Right cmd
-    -- PONG response must not have queue ID
-    NRPong -> noEntity
-    -- other server responses must have entity ID
-    _
-      | B.null entId -> Left $ CMD NO_ENTITY
-      | otherwise -> Right cmd
-    where
-      noEntity
-        | B.null entId = Right cmd
-        | otherwise = Left $ CMD HAS_AUTH
-
-data SMPQueueNtf = SMPQueueNtf
-  { smpServer :: ProtocolServer,
-    notifierId :: NotifierId,
-    notifierKey :: NtfPrivateSignKey
-  }
-  deriving (Show)
-
-instance Encoding SMPQueueNtf where
-  smpEncode SMPQueueNtf {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
-  smpP = do
-    (smpServer, notifierId, notifierKey) <- smpP
-    pure $ SMPQueueNtf smpServer notifierId notifierKey
-
-data PushProvider = PPApns
-  deriving (Eq, Ord, Show)
-
-instance Encoding PushProvider where
-  smpEncode = \case
-    PPApns -> "A"
-  smpP =
-    A.anyChar >>= \case
-      'A' -> pure PPApns
-      _ -> fail "bad PushProvider"
-
-instance TextEncoding PushProvider where
-  textEncode = \case
-    PPApns -> "apple"
-  textDecode = \case
-    "apple" -> Just PPApns
-    _ -> Nothing
-
-instance FromField PushProvider where fromField = fromTextField_ textDecode
-
-instance ToField PushProvider where toField = toField . textEncode
-
-data DeviceToken = DeviceToken PushProvider ByteString
-  deriving (Eq, Ord, Show)
-
-instance Encoding DeviceToken where
-  smpEncode (DeviceToken p t) = smpEncode (p, t)
-  smpP = DeviceToken <$> smpP <*> smpP
-
-type NtfEntityId = ByteString
-
-type NtfSubscriptionId = NtfEntityId
-
-type NtfTokenId = NtfEntityId
-
-data NtfSubStatus
-  = -- | state after SNEW
-    NSNew
-  | -- | pending connection/subscription to SMP server
-    NSPending
-  | -- | connected and subscribed to SMP server
-    NSActive
-  | -- | NEND received (we currently do not support it)
-    NSEnd
-  | -- | SMP AUTH error
-    NSSMPAuth
-  deriving (Eq, Show)
-
-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"
-    NSEnd -> "END"
-    NSSMPAuth -> "SMP_AUTH"
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NSNew
-      "PENDING" -> pure NSPending
-      "ACTIVE" -> pure NSActive
-      "END" -> pure NSEnd
-      "SMP_AUTH" -> pure NSSMPAuth
-      _ -> fail "bad NtfSubStatus"
-
-data NtfTknStatus
-  = -- | Token created in DB
-    NTNew
-  | -- | state after registration (TNEW)
-    NTRegistered
-  | -- | if initial notification failed (push provider error) or verification failed
-    NTInvalid
-  | -- | Token confirmed via notification (accepted by push provider or verification code received by client)
-    NTConfirmed
-  | -- | after successful verification (TVFY)
-    NTActive
-  | -- | after it is no longer valid (push provider error)
-    NTExpired
-  deriving (Eq, Show)
-
-instance Encoding NtfTknStatus where
-  smpEncode = \case
-    NTNew -> "NEW"
-    NTRegistered -> "REGISTERED"
-    NTInvalid -> "INVALID"
-    NTConfirmed -> "CONFIRMED"
-    NTActive -> "ACTIVE"
-    NTExpired -> "EXPIRED"
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NTNew
-      "REGISTERED" -> pure NTRegistered
-      "INVALID" -> pure NTInvalid
-      "CONFIRMED" -> pure NTConfirmed
-      "ACTIVE" -> pure NTActive
-      "EXPIRED" -> pure NTExpired
-      _ -> fail "bad NtfTknStatus"
-
-instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
-
-instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
-
-instance ToJSON NtfTknStatus where
-  toEncoding = JE.text . decodeLatin1 . smpEncode
-  toJSON = J.String . decodeLatin1 . smpEncode
-
-checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
-checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
-  Just Refl -> Right c
-  Nothing -> Left "bad command party"
-
-checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
-checkEntity' c = case testEquality (sNtfEntity @p) (sNtfEntity @p') of
-  Just Refl -> Just c
-  _ -> Nothing

src/Simplex/Messaging/Notifications/Server.hs

@@ -1,330 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Simplex.Messaging.Notifications.Server where
-
-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.Text as T
-import Data.Time.Clock.System (getSystemTime)
-import Network.Socket (ServiceName)
-import Simplex.Messaging.Client.Agent
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
-import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Server
-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 UnliftIO (async, uninterruptibleCancel)
-import UnliftIO.Concurrent (threadDelay)
-import UnliftIO.Exception
-import UnliftIO.STM
-
-runNtfServer :: (MonadRandom m, MonadUnliftIO m) => NtfServerConfig -> m ()
-runNtfServer cfg = do
-  started <- newEmptyTMVarIO
-  runNtfServerBlocking started cfg
-
-runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfServerConfig -> m ()
-runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
-
-ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
-ntfServer NtfServerConfig {transports} started = do
-  s <- asks subscriber
-  ps <- asks pushServer
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
-  where
-    runServer :: (ServiceName, ATransport) -> m ()
-    runServer (tcpPort, ATransport t) = do
-      serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
-
-    runClient :: Transport c => TProxy c -> c -> m ()
-    runClient _ h = do
-      kh <- asks serverIdentity
-      liftIO (runExceptT $ ntfServerHandshake h kh) >>= \case
-        Right th -> runNtfClientTransport th
-        Left _ -> pure ()
-
-ntfSubscriber :: forall m. MonadUnliftIO m => NtfSubscriber -> m ()
-ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
-  raceAny_ [subscribe, receiveSMP, receiveAgent]
-  where
-    subscribe :: m ()
-    subscribe = forever $ do
-      atomically (readTBQueue subQ) >>= \case
-        NtfSub NtfSubData {smpQueue} -> do
-          let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue
-          liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
-            Right _ -> pure () -- update subscription status
-            Left _e -> pure ()
-
-    receiveSMP :: m ()
-    receiveSMP = forever $ do
-      (_srv, _sessId, _ntfId, msg) <- atomically $ readTBQueue msgQ
-      case msg of
-        SMP.NMSG -> do
-          -- check when the last NMSG was received from this queue
-          -- update timestamp
-          -- check what was the last hidden notification was sent (and whether to this queue)
-          -- decide whether it should be sent as hidden or visible
-          -- construct and possibly encrypt notification
-          -- send it
-          pure ()
-        _ -> pure ()
-      pure ()
-
-    receiveAgent =
-      forever $
-        atomically (readTBQueue agentQ) >>= \case
-          CAConnected _ -> pure ()
-          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 ()
-
-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 (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
-    _ -> do
-      logError "bad notification token status"
-  where
-    deliverNotification :: PushProvider -> PushProviderClient
-    deliverNotification pp tkn ntf = do
-      deliver <- liftIO $ getPushClient s pp
-      -- 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, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
-runNtfClientTransport th@THandle {sessionId} = do
-  qSize <- asks $ clientQSize . config
-  ts <- liftIO getSystemTime
-  c <- atomically $ newNtfServerClient qSize sessionId ts
-  s <- asks subscriber
-  ps <- asks pushServer
-  expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
-    `finally` clientDisconnected c
-  where
-    disconnectThread_ c expCfg = maybe [] ((: []) . disconnectTransport th c activeAt) expCfg
-
-clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
-clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
-
-receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
-receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  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, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
-send h NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
-  t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-
-data VerificationResult = VRVerified NtfRequest | VRFailed
-
-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
-    NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do
-      r_ <- atomically $ getNtfTokenRegistration st tkn
-      pure $
-        if verifyCmdSignature sig_ signed k
-          then case r_ of
-            Just t@NtfTknData {tknVerifyKey}
-              | k == tknVerifyKey -> verifiedTknCmd t c
-              | otherwise -> VRFailed
-            _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn))
-          else VRFailed
-    NtfCmd SToken c -> do
-      t_ <- atomically $ getNtfToken st entId
-      pure $ case t_ of
-        Just t@NtfTknData {tknVerifyKey}
-          | verifyCmdSignature sig_ signed tknVerifyKey -> verifiedTknCmd t c
-          | otherwise -> VRFailed
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    _ -> pure VRFailed
-  where
-    verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
-
-client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
-client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ, intervalNotifiers} =
-  forever $
-    atomically (readTBQueue rcvQ)
-      >>= processCommand
-      >>= atomically . writeTBQueue sndQ
-  where
-    processCommand :: NtfRequest -> m (Transmission NtfResponse)
-    processCommand = \case
-      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
-        logDebug "TNEW - new token"
-        st <- asks store
-        ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
-        let dhSecret = C.dh' dhPubKey srvDhPrivKey
-        tknId <- getId
-        regCode <- getRegCode
-        atomically $ do
-          tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
-          addNtfToken st tknId tkn
-          writeTBQueue pushQ (tkn, PNVerification regCode)
-        pure (corrId, "", NRId tknId srvDhPubKey)
-      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
-            logDebug "TNEW - registered token"
-            let dhSecret = C.dh' dhPubKey srvDhPrivKey
-            -- it is required that DH secret is the same, to avoid failed verifications if notification is delaying
-            if tknDhSecret == dhSecret
-              then do
-                atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
-                pure $ NRId ntfTknId srvDhPubKey
-              else pure $ NRErr AUTH
-          TVFY code -- this allows repeated verification for cases when client connection dropped before server response
-            | (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
-              logDebug "TVFY - token verified"
-              st <- asks store
-              atomically $ writeTVar tknStatus NTActive
-              tIds <- atomically $ removeInactiveTokenRegistrations st tkn
-              forM_ tIds cancelInvervalNotifications
-              pure NROk
-            | otherwise -> do
-              logDebug "TVFY - incorrect code or token status"
-              pure $ NRErr AUTH
-          TCHK -> pure $ NRTkn status
-          TDEL -> do
-            logDebug "TDEL"
-            st <- asks store
-            atomically $ deleteNtfToken st tknId
-            cancelInvervalNotifications tknId
-            pure NROk
-          TCRN 0 -> do
-            logDebug "TCRN 0"
-            cancelInvervalNotifications tknId
-            pure NROk
-          TCRN int
-            | int < 20 -> pure $ NRErr QUOTA
-            | otherwise -> do
-              logDebug "TCRN"
-              atomically (TM.lookup tknId intervalNotifiers) >>= \case
-                Nothing -> runIntervalNotifier int
-                Just IntervalNotifier {interval, action} ->
-                  unless (interval == int) $ do
-                    uninterruptibleCancel action
-                    runIntervalNotifier int
-              pure NROk
-            where
-              runIntervalNotifier interval = do
-                action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
-                let notifier = IntervalNotifier {action, token = tkn, interval}
-                atomically $ TM.insert tknId notifier intervalNotifiers
-                where
-                  intervalNotifier delay = forever $ do
-                    threadDelay delay
-                    atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
-      NtfReqNew corrId (ANE SSubscription _newSub) -> pure (corrId, "", NROk)
-      NtfReqCmd SSubscription _sub (corrId, subId, cmd) ->
-        (corrId,subId,) <$> case cmd of
-          SNEW _newSub -> pure NROk
-          SCHK -> pure NROk
-          SDEL -> pure NROk
-          PING -> pure NRPong
-    getId :: m NtfEntityId
-    getId = getRandomBytes =<< asks (subIdBytes . config)
-    getRegCode :: m NtfRegCode
-    getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
-    getRandomBytes :: Int -> m ByteString
-    getRandomBytes n = do
-      gVar <- asks idsDrg
-      atomically (C.pseudoRandomBytes n gVar)
-    cancelInvervalNotifications :: NtfTokenId -> m ()
-    cancelInvervalNotifications tknId =
-      atomically (TM.lookupDelete tknId intervalNotifiers)
-        >>= mapM_ (uninterruptibleCancel . action)
-
--- 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

@@ -1,140 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Notifications.Server.Env where
-
-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.System (SystemTime)
-import Data.Word (Word16)
-import Data.X509.Validation (Fingerprint (..))
-import Network.Socket
-import qualified Network.TLS as T
-import Numeric.Natural
-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.Store
-import Simplex.Messaging.Protocol (CorrId, 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 UnliftIO.STM
-
-data NtfServerConfig = NtfServerConfig
-  { transports :: [(ServiceName, ATransport)],
-    subIdBytes :: Int,
-    regCodeBytes :: Int,
-    clientQSize :: Natural,
-    subQSize :: Natural,
-    pushQSize :: Natural,
-    smpAgentCfg :: SMPClientAgentConfig,
-    apnsConfig :: APNSPushClientConfig,
-    inactiveClientExpiration :: Maybe ExpirationConfig,
-    -- CA certificate private key is not needed for initialization
-    caCertificateFile :: FilePath,
-    privateKeyFile :: FilePath,
-    certificateFile :: FilePath
-  }
-
-defaultInactiveClientExpiration :: ExpirationConfig
-defaultInactiveClientExpiration =
-  ExpirationConfig
-    { ttl = 7200, -- 2 hours
-      checkInterval = 3600 -- seconds, 1 hour
-    }
-
-data NtfEnv = NtfEnv
-  { config :: NtfServerConfig,
-    subscriber :: NtfSubscriber,
-    pushServer :: NtfPushServer,
-    store :: NtfStore,
-    idsDrg :: TVar ChaChaDRG,
-    serverIdentity :: C.KeyHash,
-    tlsServerParams :: T.ServerParams,
-    serverIdentity :: C.KeyHash
-  }
-
-newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, caCertificateFile, certificateFile, privateKeyFile} = do
-  idsDrg <- newTVarIO =<< drgNew
-  store <- atomically newNtfStore
-  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
-  pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
-
-data NtfSubscriber = NtfSubscriber
-  { subQ :: TBQueue (NtfEntityRec 'Subscription),
-    smpAgent :: SMPClientAgent
-  }
-
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
-newNtfSubscriber qSize smpAgentCfg = do
-  smpAgent <- newSMPClientAgent smpAgentCfg
-  subQ <- newTBQueue qSize
-  pure NtfSubscriber {smpAgent, subQ}
-
-data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (NtfTknData, PushNotification),
-    pushClients :: TMap PushProvider PushProviderClient,
-    intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
-    apnsConfig :: APNSPushClientConfig
-  }
-
-data IntervalNotifier = IntervalNotifier
-  { action :: Async (),
-    token :: NtfTknData,
-    interval :: Word16
-  }
-
-newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
-newNtfPushServer qSize apnsConfig = do
-  pushQ <- newTBQueue qSize
-  pushClients <- TM.empty
-  intervalNotifiers <- TM.empty
-  pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
-
-newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-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 =
-  atomically (TM.lookup pp pushClients) >>= maybe (newPushClient s pp) pure
-
-data NtfRequest
-  = NtfReqNew CorrId ANewNtfEntity
-  | forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
-
-data NtfServerClient = NtfServerClient
-  { rcvQ :: TBQueue NtfRequest,
-    sndQ :: TBQueue (Transmission NtfResponse),
-    sessionId :: ByteString,
-    connected :: TVar Bool,
-    activeAt :: TVar SystemTime
-  }
-
-newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
-newNtfServerClient qSize sessionId ts = do
-  rcvQ <- newTBQueue qSize
-  sndQ <- newTBQueue qSize
-  connected <- newTVar True
-  activeAt <- newTVar ts
-  return NtfServerClient {rcvQ, sndQ, sessionId, connected, activeAt}

src/Simplex/Messaging/Notifications/Server/Push/.gitignore

@@ -1 +0,0 @@
-local.env

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

@@ -1,349 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use newtype instead of data" #-}
-
-module Simplex.Messaging.Notifications.Server.Push.APNS where
-
-import Control.Logger.Simple
-import Control.Monad.Except
-import Crypto.Hash.Algorithms (SHA256 (..))
-import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
-import Crypto.Random (ChaChaDRG, drgNew)
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
-import Data.Aeson (FromJSON, ToJSON, (.=))
-import qualified Data.Aeson as J
-import qualified Data.Aeson.Encoding as JE
-import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as U
-import Data.ByteString.Builder (lazyByteString)
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.CaseInsensitive as CI
-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)
-import Network.HTTP.Types (HeaderName, Status)
-import qualified Network.HTTP.Types as N
-import Network.HTTP2.Client (Request)
-import qualified Network.HTTP2.Client as H
-import Network.Socket (HostName, ServiceName)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
-import Simplex.Messaging.Protocol (NotifierId, SMPServer)
-import Simplex.Messaging.Transport.HTTP2.Client
-import System.Environment (getEnv)
-import UnliftIO.STM
-
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show, Generic)
-
-instance ToJSON JWTHeader where toEncoding = J.genericToEncoding J.defaultOptions
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show, Generic)
-
-instance ToJSON JWTClaims where toEncoding = J.genericToEncoding J.defaultOptions
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- 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 SMPServer NotifierId
-  | PNAlert Text
-  | PNCheckMessages
-
-data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
-  deriving (Show, Generic)
-
-instance ToJSON APNSNotification where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-data APNSNotificationBody
-  = APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
-  | APNSBackground {contentAvailable :: Int}
-  | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text}
-  deriving (Show, Generic)
-
-apnsJSONOptions :: J.Options
-apnsJSONOptions = J.defaultOptions {J.omitNothingFields = True, J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'}
-
-instance ToJSON APNSNotificationBody where
-  toJSON = J.genericToJSON apnsJSONOptions
-  toEncoding = J.genericToEncoding apnsJSONOptions
-
-type APNSNotificationData = Map Text Text
-
-data APNSAlertBody = APNSAlertObject {title :: Text, subtitle :: Text, body :: Text} | APNSAlertText Text
-  deriving (Show)
-
-instance ToJSON APNSAlertBody where
-  toEncoding = \case
-    APNSAlertObject {title, subtitle, body} -> J.pairs $ "title" .= title <> "subtitle" .= subtitle <> "body" .= body
-    APNSAlertText t -> JE.text t
-  toJSON = \case
-    APNSAlertObject {title, subtitle, body} -> J.object ["title" .= title, "subtitle" .= subtitle, "body" .= body]
-    APNSAlertText t -> J.String t
-
--- APNS notification types
---
--- Visible alerts:
--- {
---    "aps" : {
---       "alert" : {
---          "title" : "Game Request",
---          "subtitle" : "Five Card Draw",
---          "body" : "Bob wants to play poker"
---       },
---       "badge" : 9,
---       "sound" : "bingbong.aiff",
---       "category" : "GAME_INVITATION"
---    },
---    "gameID" : "12345678"
--- }
---
--- Simple text alert:
--- {"aps":{"alert":"you have a new message"}}
---
--- Background notification to fetch content
--- {"aps":{"content-available":1}}
---
--- Mutable content notification that must be shown but can be processed before before being shown (up to 30 sec)
--- {
---    "aps" : {
---       "category" : "SECRET",
---       "mutable-content" : 1,
---       "alert" : {
---          "title" : "Secret Message!",
---          "body"  : "(Encrypted)"
---      },
---    },
---    "ENCRYPTED_DATA" : "Salted__·öîQÊ$UDì_¶Ù∞èΩ^¬%gq∞NÿÒQùw"
--- }
-
-data APNSPushClientConfig = APNSPushClientConfig
-  { tokenTTL :: Int64,
-    authKeyFileEnv :: String,
-    authKeyAlg :: Text,
-    authKeyIdEnv :: String,
-    paddedNtfLength :: Int,
-    appName :: ByteString,
-    appTeamId :: Text,
-    apnsHost :: HostName,
-    apnsPort :: ServiceName,
-    http2cfg :: HTTP2ClientConfig
-  }
-  deriving (Show)
-
-defaultAPNSPushClientConfig :: APNSPushClientConfig
-defaultAPNSPushClientConfig =
-  APNSPushClientConfig
-    { 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 = 256,
-      appName = "chat.simplex.app",
-      appTeamId = "5NN7GUYB6T",
-      apnsHost = "api.sandbox.push.apple.com",
-      apnsPort = "443",
-      http2cfg = defaultHTTP2ClientConfig
-    }
-
-data APNSPushClient = APNSPushClient
-  { https2Client :: TVar (Maybe HTTP2Client),
-    privateKey :: EC.PrivateKey,
-    jwtHeader :: JWTHeader,
-    jwtToken :: TVar (JWTToken, SignedJWTToken),
-    nonceDrg :: TVar ChaChaDRG,
-    apnsCfg :: APNSPushClientConfig
-  }
-
-createAPNSPushClient :: APNSPushClientConfig -> IO APNSPushClient
-createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
-  https2Client <- newTVarIO Nothing
-  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, apnsCfg}
-
-getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
-getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do
-  (jwt, signedJWT) <- readTVarIO jwtToken
-  age <- jwtTokenAge jwt
-  if age < tokenTTL
-    then pure signedJWT
-    else do
-      t@(_, signedJWT') <- mkApnsJWTToken appTeamId jwtHeader privateKey
-      atomically $ writeTVar jwtToken t
-      pure signedJWT'
-  where
-    jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
-
-mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
-mkApnsJWTToken appTeamId jwtHeader privateKey = do
-  jwt <- mkJWTToken jwtHeader appTeamId
-  signedJWT <- signedJWTToken privateKey jwt
-  pure (jwt, signedJWT)
-
-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
-    Left e -> putStrLn $ "Error connecting to APNS: " <> show e
-  pure r
-  where
-    disconnected = atomically $ writeTVar https2Client Nothing
-
-getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
-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)
-
-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 ["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 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
-  signedJWT <- getApnsJWTToken c
-  pure $ H.requestBuilder N.methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf)
-  where
-    path = "/3/device/" <> tkn
-    headers signedJWT =
-      [ (hApnsTopic, appName $ apnsCfg (c :: APNSPushClient)),
-        (hApnsPushType, pushType aps),
-        (N.hAuthorization, "bearer " <> signedJWT)
-      ]
-        <> [(hApnsPriority, "5") | isBackground aps]
-    isBackground = \case
-      APNSBackground {} -> True
-      _ -> False
-    pushType = \case
-      APNSBackground {} -> "background"
-      _ -> "alert"
-
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid
-  | PPRetryLater
-  | PPPermanentError
-  deriving (Show)
-
-type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
-
--- this is not a newtype on purpose to have a correct JSON encoding as a record
-data APNSErrorResponse = APNSErrorResponse {reason :: Text}
-  deriving (Generic, FromJSON)
-
-apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-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
-  req <- liftIO $ apnsRequest c tknStr apnsNtf
-  HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
-  let status = H.responseStatus response
-      reason' = maybe "" reason $ J.decodeStrict' respBody
-  logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
-  result status reason'
-  where
-    result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
-    result status reason'
-      | status == Just N.ok200 = pure ()
-      | status == Just N.badRequest400 =
-        case reason' of
-          "BadDeviceToken" -> throwError PPTokenInvalid
-          "DeviceTokenNotForTopic" -> throwError PPTokenInvalid
-          "TopicDisallowed" -> throwError PPPermanentError
-          _ -> err status reason'
-      | status == Just N.forbidden403 = case reason' of
-        "ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
-        "InvalidProviderToken" -> throwError PPPermanentError
-        _ -> err status reason'
-      | status == Just N.gone410 = throwError PPTokenInvalid
-      | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-      -- 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
-    liftHTTPS2 a = ExceptT $ first PPConnection <$> a
-
-hApnsTopic :: HeaderName
-hApnsTopic = CI.mk "apns-topic"
-
-hApnsPushType :: HeaderName
-hApnsPushType = CI.mk "apns-push-type"
-
-hApnsPriority :: HeaderName
-hApnsPriority = CI.mk "apns-priority"

src/Simplex/Messaging/Notifications/Server/Push/testpush.sh

@@ -1,26 +0,0 @@
-#!/bin/sh
-
-export TEAM_ID=5NN7GUYB6T
-# export APNS_KEY_FILE=""
-# export APNS_KEY_ID=""
-export TOPIC=chat.simplex.app
-# export DEVICE_TOKEN=
-export APNS_HOST_NAME=api.sandbox.push.apple.com
-
-export JWT_ISSUE_TIME=$(date +%s)
-export JWT_HEADER=$(printf '{"alg":"ES256","kid":"%s"}' "${APNS_KEY_ID}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export JWT_CLAIMS=$(printf '{"iss":"%s","iat":%d}' "${TEAM_ID}" "${JWT_ISSUE_TIME}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export JWT_HEADER_CLAIMS="${JWT_HEADER}.${JWT_CLAIMS}"
-
-export JWT_SIGNED_HEADER_CLAIMS=$(printf "${JWT_HEADER_CLAIMS}" | openssl dgst -binary -sha256 -sign "${APNS_KEY_FILE}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export AUTHENTICATION_TOKEN="${JWT_HEADER}.${JWT_CLAIMS}.${JWT_SIGNED_HEADER_CLAIMS}"
-
-# simple alert
-# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"},"data":{"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
-
-# background notification
-# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: background" --header "apns-priority: 5" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"content-available":1}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
-
-# mutable-content notification
-# NTF_CAT_CHECK_MESSAGE category will not show alert if the app is in foreground
-curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"category": "NTF_CAT_CHECK_MESSAGE__SECRET", "mutable-content": 1, "alert":"received encrypted message"}, "data": {"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}

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

@@ -1,155 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Simplex.Messaging.Notifications.Server.Store where
-
-import Control.Concurrent.STM
-import Control.Monad
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.Map.Strict as M
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (whenM, ($>>=))
-
-data NtfStore = NtfStore
-  { tokens :: TMap NtfTokenId NtfTknData,
-    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId)
-  }
-
-newNtfStore :: STM NtfStore
-newNtfStore = do
-  tokens <- TM.empty
-  tokenRegistrations <- TM.empty
-  pure NtfStore {tokens, tokenRegistrations}
-
-data NtfTknData = NtfTknData
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: TVar NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    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
-  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
-  { smpQueue :: SMPQueueNtf,
-    tokenId :: NtfTokenId,
-    subStatus :: TVar NtfSubStatus
-  }
-
-data NtfEntityRec (e :: NtfEntity) where
-  NtfTkn :: NtfTknData -> NtfEntityRec 'Token
-  NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
-
-getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getNtfToken st tknId = TM.lookup tknId (tokens st)
-
-addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
-addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
-  TM.insert tknId tkn $ tokens st
-  TM.lookup token regs >>= \case
-    Just tIds -> TM.insert regKey tknId tIds
-    _ -> do
-      tIds <- TM.singleton regKey tknId
-      TM.insert token tIds regs
-  where
-    regs = tokenRegistrations st
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
-getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
-  TM.lookup token (tokenRegistrations st)
-    $>>= TM.lookup regKey
-    $>>= (`TM.lookup` tokens st)
-  where
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
-removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
-  TM.lookup token (tokenRegistrations st)
-    >>= maybe (pure []) removeRegs
-  where
-    removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId]
-    removeRegs tknRegs = do
-      tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs
-      forM_ tIds $ \(regKey, tId') -> do
-        TM.delete regKey tknRegs
-        TM.delete tId' $ tokens st
-      pure $ map snd tIds
-
-deleteNtfToken :: NtfStore -> NtfTokenId -> STM ()
-deleteNtfToken st tknId = do
-  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
-
--- 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/Transport.hs

@@ -1,19 +0,0 @@
-module Simplex.Messaging.Notifications.Transport where
-
-import Control.Monad.Except
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Transport
-
-ntfBlockSize :: Int
-ntfBlockSize = 512
-
--- | Notifcations server transport handshake.
-ntfServerHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c _ = pure $ ntfTHandle c
-
--- | Notifcations server client transport handshake.
-ntfClientHandshake :: Transport c => c -> C.KeyHash -> 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}

src/Simplex/Messaging/Parsers.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -13,15 +12,16 @@ import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum, toLower)
-import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601 (parseISO8601)
 import Data.Typeable (Typeable)
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.Internal as PI
+import qualified Database.PostgreSQL.Simple.Ok as PO
 import Database.SQLite.Simple (ResultError (..), SQLData (..))
-import Database.SQLite.Simple.FromField (FieldParser, returnError)
-import Database.SQLite.Simple.Internal (Field (..))
-import Database.SQLite.Simple.Ok (Ok (Ok))
+import qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.Internal as SI
+import qualified Database.SQLite.Simple.Ok as SO
 import Simplex.Messaging.Util ((<$?>))
 import Text.Read (readMaybe)
 
@@ -72,24 +72,24 @@ wordEnd c = c == ' ' || c == '\n'
 parseString :: (ByteString -> Either String a) -> (String -> a)
 parseString p = either error id . p . B.pack
 
-blobFieldParser :: Typeable k => Parser k -> FieldParser k
+blobFieldParser :: Typeable k => Parser k -> SF.FieldParser k
 blobFieldParser = blobFieldDecoder . parseAll
 
-blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> SF.FieldParser k
 blobFieldDecoder dec = \case
-  f@(Field (SQLBlob b) _) ->
+  f@(SI.Field (SQLBlob b) _) ->
     case dec b of
-      Right k -> Ok k
-      Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
-  f -> returnError ConversionFailed f "expecting SQLBlob column type"
+      Right k -> SO.Ok k
+      Left e -> SF.returnError SF.ConversionFailed f ("couldn't parse field: " ++ e)
+  f -> SF.returnError SF.ConversionFailed f "expecting SQLBlob column type"
 
-fromTextField_ :: (Typeable a) => (Text -> Maybe a) -> Field -> Ok a
-fromTextField_ fromText = \case
-  f@(Field (SQLText t) _) ->
-    case fromText t of
-      Just x -> Ok x
-      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
-  f -> returnError ConversionFailed f "expecting SQLText column type"
+-- blobFieldDecoderPostgres :: Typeable k => (ByteString -> Either String k) -> PF.FieldParser k
+-- blobFieldDecoderPostgres dec = \case
+--   f@(PI.Field b _ _) ->
+--     case dec b of
+--       Right k -> PO.Ok k
+--       Left e -> PF.returnError PF.ConversionFailed f ("couldn't parse field: " ++ e)
+--   f -> PF.returnError PF.ConversionFailed f "expecting SQLBlob column type"
 
 fstToLower :: String -> String
 fstToLower "" = ""
@@ -108,18 +108,13 @@ enumJSON tagModifier =
     }
 
 sumTypeJSON :: (String -> String) -> J.Options
-#if defined(darwin_HOST_OS) && defined(swiftJSON)
 sumTypeJSON = singleFieldJSON
-#else
-sumTypeJSON = taggedObjectJSON
-#endif
 
 taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.TaggedObject "type" "data",
       J.constructorTagModifier = tagModifier,
-      J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
       J.omitNothingFields = True
     }
@@ -129,7 +124,6 @@ singleFieldJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.ObjectWithSingleField,
       J.constructorTagModifier = tagModifier,
-      J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
       J.omitNothingFields = True
     }

src/Simplex/Messaging/Protocol.hs

@@ -1,26 +1,23 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 -- |
--- Module      : Simplex.Messaging.ProtocolEncoding
+-- Module      : Simplex.Messaging.Protocol
 -- Copyright   : (c) simplex.chat
 -- License     : AGPL-3
 --
@@ -40,7 +37,7 @@ module Simplex.Messaging.Protocol
     e2eEncMessageLength,
 
     -- * SMP protocol types
-    ProtocolEncoding (..),
+    Protocol,
     Command (..),
     Party (..),
     Cmd (..),
@@ -58,10 +55,7 @@ module Simplex.Messaging.Protocol
     PubHeader (..),
     ClientMessage (..),
     PrivHeader (..),
-    Protocol (..),
-    ProtocolServer (..),
-    SMPServer,
-    pattern SMPServer,
+    SMPServer (..),
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -80,11 +74,9 @@ module Simplex.Messaging.Protocol
     MsgBody,
 
     -- * Parse and serialize
-    ProtocolMsgTag (..),
-    messageTagP,
     encodeTransmission,
     transmissionP,
-    _smpP,
+    encodeProtocol,
 
     -- * TCP transport functions
     tPut,
@@ -116,7 +108,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
-import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
 import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
@@ -169,7 +161,7 @@ data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
 deriving instance Show Cmd
 
 -- | Parsed SMP transmission without signature, size and session ID.
-type Transmission c = (CorrId, EntityId, c)
+type Transmission c = (CorrId, QueueId, c)
 
 -- | signed parsed transmission, with original raw bytes and parsing error.
 type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
@@ -180,15 +172,14 @@ type Signed = ByteString
 data RawTransmission = RawTransmission
   { signature :: ByteString,
     signed :: ByteString,
-    sessId :: SessionId,
+    sessId :: ByteString,
     corrId :: ByteString,
-    entityId :: ByteString,
+    queueId :: ByteString,
     command :: ByteString
   }
-  deriving (Show)
 
 -- | unparsed sent SMP transmission with signature, without session ID.
-type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
+type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString)
 
 -- | unparsed sent SMP transmission with signature.
 type SentRawTransmission = (Maybe C.ASignature, ByteString)
@@ -203,9 +194,7 @@ type SenderId = QueueId
 type NotifierId = QueueId
 
 -- | SMP queue ID on the server.
-type QueueId = EntityId
-
-type EntityId = ByteString
+type QueueId = ByteString
 
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
@@ -275,7 +264,7 @@ class ProtocolMsgTag t where
 
 messageTagP :: ProtocolMsgTag t => Parser t
 messageTagP =
-  maybe (fail "bad message") pure . decodeTag
+  maybe (fail "bad command") pure . decodeTag
     =<< (A.takeTill (== ' ') <* optional A.space)
 
 instance PartyI p => Encoding (CommandTag p) where
@@ -383,43 +372,32 @@ instance Encoding ClientMessage where
   smpEncode (ClientMessage h msg) = smpEncode h <> msg
   smpP = ClientMessage <$> smpP <*> A.takeByteString
 
-type SMPServer = ProtocolServer
-
-pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer
-pattern SMPServer host port keyHash = ProtocolServer host port keyHash
-
-{-# COMPLETE SMPServer #-}
-
 -- | SMP server location and transport key digest (hash).
-data ProtocolServer = ProtocolServer
+data SMPServer = SMPServer
   { host :: HostName,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
   deriving (Eq, Ord, Show)
 
-instance IsString ProtocolServer where
+instance IsString SMPServer where
   fromString = parseString strDecode
 
-instance Encoding ProtocolServer where
-  smpEncode ProtocolServer {host, port, keyHash} =
+instance Encoding SMPServer where
+  smpEncode SMPServer {host, port, keyHash} =
     smpEncode (host, port, keyHash)
   smpP = do
     (host, port, keyHash) <- smpP
-    pure ProtocolServer {host, port, keyHash}
+    pure SMPServer {host, port, keyHash}
 
-instance StrEncoding ProtocolServer where
-  strEncode ProtocolServer {host, port, keyHash} =
+instance StrEncoding SMPServer where
+  strEncode SMPServer {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 ToJSON ProtocolServer where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
+    pure SMPServer {host, port, keyHash}
 
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
@@ -530,8 +508,8 @@ data CommandError
     NO_AUTH
   | -- | transmission has credentials that are not allowed for this command
     HAS_AUTH
-  | -- | transmission has no required entity ID (e.g. SMP queue)
-    NO_ENTITY
+  | -- | transmission has no required queue ID
+    NO_QUEUE
   deriving (Eq, Generic, Read, Show)
 
 instance ToJSON CommandError where
@@ -552,31 +530,17 @@ transmissionP = do
     trn signature signed = do
       sessId <- smpP
       corrId <- smpP
-      entityId <- smpP
+      queueId <- smpP
       command <- A.takeByteString
-      pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
+      pure RawTransmission {signature, signed, sessId, corrId, queueId, command}
 
-class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
-  type ProtocolCommand msg = cmd | cmd -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-  protocolPing :: ProtocolCommand msg
-  protocolError :: msg -> Maybe ErrorType
-
-instance Protocol BrokerMsg where
-  type ProtocolCommand BrokerMsg = Cmd
-  protocolClientHandshake = smpClientHandshake
-  protocolPing = Cmd SSender PING
-  protocolError = \case
-    ERR e -> Just e
-    _ -> Nothing
-
-class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
+class Protocol msg where
   type Tag msg
   encodeProtocol :: msg -> ByteString
   protocolP :: Tag msg -> Parser msg
   checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
 
-instance PartyI p => ProtocolEncoding (Command p) where
+instance PartyI p => Protocol (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol = \case
     NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
@@ -603,7 +567,7 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | otherwise -> Right cmd
     -- SEND must have queue ID, signature is not always required
     SEND _
-      | B.null queueId -> Left $ CMD NO_ENTITY
+      | B.null queueId -> Left $ CMD NO_QUEUE
       | otherwise -> Right cmd
     -- PING must not have queue ID or signature
     PING
@@ -614,7 +578,7 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding Cmd where
+instance Protocol Cmd where
   type Tag Cmd = CmdTag
   encodeProtocol (Cmd _ c) = encodeProtocol c
 
@@ -636,7 +600,7 @@ instance ProtocolEncoding Cmd where
 
   checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
 
-instance ProtocolEncoding BrokerMsg where
+instance Protocol BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
@@ -662,7 +626,7 @@ instance ProtocolEncoding BrokerMsg where
     PONG_ -> pure PONG
 
   checkCredentials (_, _, queueId, _) cmd = case cmd of
-    -- IDS response should not have queue ID
+    -- IDS response must not have queue ID
     IDS _ -> Right cmd
     -- ERR response does not always have queue ID
     ERR _ -> Right cmd
@@ -672,14 +636,14 @@ instance ProtocolEncoding BrokerMsg where
       | otherwise -> Left $ CMD HAS_AUTH
     -- other broker responses must have queue ID
     _
-      | B.null queueId -> Left $ CMD NO_ENTITY
+      | B.null queueId -> Left $ CMD NO_QUEUE
       | otherwise -> Right cmd
 
 _smpP :: Encoding a => Parser a
 _smpP = A.space *> smpP
 
 -- | Parse SMP protocol commands and broker messages
-parseProtocol :: ProtocolEncoding msg => ByteString -> Either ErrorType msg
+parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg
 parseProtocol s =
   let (tag, params) = B.break (== ' ') s
    in case decodeTag tag of
@@ -727,22 +691,21 @@ instance Encoding CommandError where
     SYNTAX -> "SYNTAX"
     NO_AUTH -> "NO_AUTH"
     HAS_AUTH -> "HAS_AUTH"
-    NO_ENTITY -> "NO_ENTITY"
+    NO_QUEUE -> "NO_QUEUE"
   smpP =
     A.takeTill (== ' ') >>= \case
       "UNKNOWN" -> pure UNKNOWN
       "SYNTAX" -> pure SYNTAX
       "NO_AUTH" -> pure NO_AUTH
       "HAS_AUTH" -> pure HAS_AUTH
-      "NO_ENTITY" -> pure NO_ENTITY
-      "NO_QUEUE" -> pure NO_ENTITY
+      "NO_QUEUE" -> pure NO_QUEUE
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
 tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
 tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
 
-encodeTransmission :: ProtocolEncoding c => ByteString -> Transmission c -> ByteString
+encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString
 encodeTransmission sessionId (CorrId corrId, queueId, command) =
   smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
 
@@ -751,14 +714,18 @@ tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmissi
 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 (SignedTransmission cmd)
+tGet ::
+  forall cmd c m.
+  (Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) =>
+  THandle c ->
+  m (SignedTransmission cmd)
 tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
   where
     decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case
-      Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
+      Right RawTransmission {signature, signed, sessId, corrId, queueId, command}
         | sessId == sessionId ->
-          let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
+          let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature
            in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
         | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
       Left _ -> tError ""
@@ -767,6 +734,6 @@ tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
     tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
 
     tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
-    tParseValidate signed t@(sig, corrId, entityId, command) = do
+    tParseValidate signed t@(sig, corrId, queueId, command) = do
       let cmd = parseProtocol command >>= checkCredentials t
-      pure (sig, signed, (CorrId corrId, entityId, cmd))
+      pure (sig, signed, (CorrId corrId, queueId, cmd))

src/Simplex/Messaging/Server.hs

@@ -5,9 +5,7 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -25,16 +23,9 @@
 -- and optional append only log of SMP queue records.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
-module Simplex.Messaging.Server
-  ( runSMPServer,
-    runSMPServerBlocking,
-    disconnectTransport,
-    verifyCmdSignature,
-    dummyVerifyCmd,
-  )
-where
+module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where
 
-import Control.Logger.Simple
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
@@ -43,36 +34,23 @@ import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
-import Data.List (intercalate)
 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.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.Clock.System (getSystemTime)
 import Data.Type.Equality
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
-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 (MsgQueue)
 import Simplex.Messaging.Server.QueueStore
 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.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
-import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
@@ -90,36 +68,37 @@ 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 :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
-
-smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m ()
-smpServer started = do
-  s <- asks server
-  cfg@ServerConfig {transports} <- asks config
-  restoreServerMessages
-  raceAny_
-    ( serverThread s subscribedQ subscribers subscriptions cancelSub :
-      serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
-      map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
-    )
-    `finally` (withLog closeStoreLog >> saveServerMessages)
+runSMPServerBlocking started cfg@ServerConfig {transports} = do
+  env <- newEnv cfg
+  runReaderT smpServer env
   where
-    runServer :: (ServiceName, ATransport) -> m ()
+    smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
+    smpServer = do
+      s <- asks server
+      raceAny_
+        ( serverThread s subscribedQ subscribers subscriptions cancelSub :
+          serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
+          map runServer transports
+        )
+        `finally` withLog closeStoreLog
+
+    runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
       runTransportServer started tcpPort serverParams (runClient t)
 
     serverThread ::
-      forall s.
+      forall m' s.
+      MonadUnliftIO m' =>
       Server ->
       (Server -> TBQueue (QueueId, Client)) ->
-      (Server -> TMap QueueId Client) ->
-      (Client -> TMap QueueId s) ->
-      (s -> m ()) ->
-      m ()
+      (Server -> TVar (M.Map QueueId Client)) ->
+      (Client -> TVar (M.Map QueueId s)) ->
+      (s -> m' ()) ->
+      m' ()
     serverThread s subQ subs clientSubs unsub = forever $ do
       atomically updateSubscribers
-        $>>= endPreviousSubscriptions
+        >>= fmap join . mapM endPreviousSubscriptions
         >>= mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
@@ -131,90 +110,36 @@ smpServer started = do
                   else 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)
+          stateTVar (subs s) (\cs -> (M.lookup qId cs, M.insert qId clnt cs))
+            >>= fmap join . mapM clientToBeNotified
+        endPreviousSubscriptions :: (QueueId, Client) -> m' (Maybe s)
         endPreviousSubscriptions (qId, c) = do
           void . forkIO . atomically $
             writeTBQueue (sndQ c) (CorrId "", qId, END)
-          atomically $ TM.lookupDelete qId (clientSubs c)
+          atomically . stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss)
 
-    expireMessagesThread_ :: ServerConfig -> [m ()]
-    expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
-    expireMessagesThread_ _ = []
-
-    expireMessages :: ExpirationConfig -> m ()
-    expireMessages expCfg = do
-      ms <- asks msgStore
-      quota <- asks $ msgQueueQuota . config
-      let interval = checkInterval expCfg * 1000000
-      forever $ do
-        threadDelay interval
-        old <- liftIO $ expireBeforeEpoch expCfg
-        rIds <- M.keysSet <$> readTVarIO ms
-        forM_ rIds $ \rId ->
-          atomically (getMsgQueue ms rId quota)
-            >>= atomically . (`deleteExpiredMsgs` old)
-
-    serverStatsThread_ :: ServerConfig -> [m ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime} =
-      [logServerStats logStatsStartTime interval]
-    serverStatsThread_ _ = []
-
-    logServerStats :: Int -> Int -> m ()
-    logServerStats startAt logInterval = do
-      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      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, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
-      let interval = 1000000 * logInterval
-      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, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
-      liftIO (runExceptT $ smpServerHandshake h kh) >>= \case
+      liftIO (runExceptT $ serverHandshake h kh) >>= \case
         Right th -> runClientTransport th
         Left _ -> pure ()
 
 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 sessionId ts
+  c <- atomically $ newClient q sessionId
   s <- asks server
-  expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
+  raceAny_ [send th c, client c s, receive th c]
     `finally` clientDisconnected c
-  where
-    disconnectThread_ c (Just expCfg) = [disconnectTransport th c activeAt expCfg]
-    disconnectThread_ _ _ = []
 
 clientDisconnected :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
 clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
   mapM_ cancelSub subs
-  atomically $ writeTVar subscriptions M.empty
   cs <- asks $ subscribers . server
-  atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
+  atomically . mapM_ (modifyTVar cs . M.update deleteCurrentClient) $ M.keys subs
   where
     deleteCurrentClient :: Client -> Maybe Client
     deleteCurrentClient c'
@@ -226,13 +151,12 @@ sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
 cancelSub :: MonadUnliftIO m => Sub -> m ()
 cancelSub = \case
-  Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
+  Sub {subThread = SubThread t} -> killThread t
   _ -> return ()
 
 receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
-receive th Client {rcvQ, sndQ, activeAt} = forever $ do
+receive th Client {rcvQ, sndQ} = forever $ do
   (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
   case cmdOrError of
     Left e -> write sndQ (corrId, queueId, ERR e)
     Right cmd -> do
@@ -244,27 +168,16 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
     write q t = atomically $ writeTBQueue q t
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
-send h Client {sndQ, sessionId, activeAt} = forever $ do
+send h Client {sndQ, sessionId} = forever $ do
   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 sessionId t)
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-
-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
-    threadDelay interval
-    old <- expireBeforeEpoch expCfg
-    ts <- readTVarIO $ activeAt c
-    when (systemSeconds ts < old) $ closeConnection connection
+  liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
 
 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 $ verifyCmdSignature sig_ signed k
-    Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
+    Cmd SRecipient (NEW k _) -> pure $ verifySignature k
+    Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
     Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
     Cmd SSender PING -> pure True
     Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
@@ -273,21 +186,18 @@ verifyTransmission sig_ signed queueId cmd = do
     verifyCmd party f = do
       st <- asks queueStore
       q <- atomically $ getQueue st party queueId
-      pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
+      pure $ either (const $ maybe False dummyVerify sig_ `seq` False) f q
     verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
-    verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
-
-verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
-verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
-  where
+    verifyMaybe = maybe (isNothing sig_) verifySignature
+    verifySignature :: C.APublicVerifyKey -> Bool
+    verifySignature key = maybe False (verify key) sig_
     verify :: C.APublicVerifyKey -> C.ASignature -> Bool
     verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =
       case (testEquality a a', C.signatureSize k == C.signatureSize s) of
         (Just Refl, True) -> C.verify' k s signed
-        _ -> dummyVerifyCmd signed sig `seq` False
-
-dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
-dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
+        _ -> dummyVerify sig `seq` False
+    dummyVerify :: C.ASignature -> Bool
+    dummyVerify (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
 
 -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
 -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
@@ -320,11 +230,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
           case command of
-            NEW rKey dhKey ->
-              ifM
-                (asks $ allowNewQueues . config)
-                (createQueue st rKey dhKey)
-                (pure (corrId, queueId, ERR AUTH))
+            NEW rKey dhKey -> createQueue st rKey dhKey
             SUB -> subscribeQueue queueId
             ACK -> acknowledgeMsg
             KEY sKey -> secureQueue_ st sKey
@@ -360,8 +266,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                 Left e -> pure $ ERR e
                 Right _ -> do
                   withLog (`logCreateById` rId)
-                  stats <- asks serverStats
-                  atomically $ modifyTVar (qCreated stats) (+ 1)
                   subscribeQueue rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
@@ -378,8 +282,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
         secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
         secureQueue_ st sKey = do
           withLog $ \s -> logSecureQueue s queueId sKey
-          stats <- asks serverStats
-          atomically $ modifyTVar (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
         addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
@@ -407,42 +309,32 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
 
         getSubscription :: RecipientId -> STM Sub
         getSubscription rId = do
-          TM.lookup rId subscriptions >>= \case
+          subs <- readTVar subscriptions
+          case M.lookup rId subs of
             Just s -> tryTakeTMVar (delivered s) $> s
             Nothing -> do
               writeTBQueue subscribedQ (rId, clnt)
               s <- newSubscription
-              TM.insert rId s subscriptions
+              writeTVar subscriptions $ M.insert rId s subs
               return s
 
         subscribeNotifications :: m (Transmission BrokerMsg)
         subscribeNotifications = atomically $ do
-          unlessM (TM.member queueId ntfSubscriptions) $ do
+          subs <- readTVar ntfSubscriptions
+          when (isNothing $ M.lookup queueId subs) $ do
             writeTBQueue ntfSubscribedQ (queueId, clnt)
-            TM.insert queueId () ntfSubscriptions
+            writeTVar ntfSubscriptions $ M.insert queueId () subs
           pure ok
 
         acknowledgeMsg :: m (Transmission BrokerMsg)
         acknowledgeMsg =
           atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
             >>= \case
-              Just (Just s) -> do
-                stats <- asks serverStats
-                atomically $ modifyTVar (msgRecv stats) (+ 1)
-                atomically $ updateActiveQueues stats queueId
-                deliverMessage tryDelPeekMsg queueId s
+              Just (Just s) -> deliverMessage tryDelPeekMsg queueId s
               _ -> return $ err NO_MSG
 
-        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
-        updateActiveQueues stats qId = do
-          updatePeriod dayMsgQueues
-          updatePeriod weekMsgQueues
-          updatePeriod monthMsgQueues
-          where
-            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
-
         withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
-        withSub rId f = mapM f =<< TM.lookup rId subscriptions
+        withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
 
         sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)
         sendMessage st msgBody
@@ -459,20 +351,13 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                   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
+                    quota <- asks $ msgQueueQuota . config
+                    atomically $ do
+                      q <- getMsgQueue ms (recipientId qr) quota
                       ifM (isFull q) (pure $ err QUOTA) $ do
                         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
@@ -484,7 +369,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                 trySendNotification :: STM ()
                 trySendNotification =
                   forM_ (notifier qr) $ \(nId, _) ->
-                    mapM_ (writeNtf nId) =<< TM.lookup nId notifiers
+                    mapM_ (writeNtf nId) . M.lookup nId =<< readTVar notifiers
 
                 writeNtf :: NotifierId -> Client -> STM ()
                 writeNtf nId Client {sndQ = q} =
@@ -505,7 +390,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             forkSub :: MsgQueue -> m ()
             forkSub q = do
               atomically . setSub $ \s -> s {subThread = SubPending}
-              t <- mkWeakThreadId =<< forkIO (subscriber q)
+              t <- forkIO $ subscriber q
               atomically . setSub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
@@ -518,7 +403,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
               void setDelivered
 
             setSub :: (Sub -> Sub) -> STM ()
-            setSub f = TM.adjust f rId subscriptions
+            setSub f = modifyTVar subscriptions $ M.adjust f rId
 
             setDelivered :: STM (Maybe Bool)
             setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
@@ -530,8 +415,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
         delQueueAndMsgs st = do
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
-          stats <- asks serverStats
-          atomically $ modifyTVar (qDeleted stats) (+ 1)
           atomically $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -554,35 +437,11 @@ withLog action = do
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
-  atomically (C.pseudoRandomBytes n gVar)
+  atomically (randomBytes n gVar)
 
-saveServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
-saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
-  where
-    saveMessages f = do
-      liftIO $ putStrLn $ "saving messages to file " <> f
-      ms <- asks msgStore
-      liftIO . withFile f WriteMode $ \h ->
-        readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
-      where
-        saveQueueMsgs ms h rId =
-          atomically (flushMsgQueue ms 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
-      liftIO $ putStrLn $ "restoring messages from file " <> f
-      ms <- asks msgStore
-      quota <- asks $ msgQueueQuota . config
-      liftIO $ mapM_ (restoreMsg ms quota) . B.lines =<< B.readFile f
-      renameFile f $ f <> ".bak"
-      where
-        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)
+randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
+randomBytes n gVar = do
+  g <- readTVar gVar
+  let (bytes, g') = randomBytesGenerate n g
+  writeTVar gVar g'
+  return bytes

src/Simplex/Messaging/Server/CLI.hs

@@ -1,284 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Simplex.Messaging.Server.CLI where
-
-import Control.Monad
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
-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.Transport (ATransport (..), TLS, Transport (..))
-import Simplex.Messaging.Transport.Server (loadFingerprint)
-import Simplex.Messaging.Transport.WebSockets (WS)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
-import System.Exit (exitFailure)
-import System.FilePath (combine)
-import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
-import System.Process (readCreateProcess, shell)
-import Text.Read (readMaybe)
-
-data ServerCLIConfig cfg = ServerCLIConfig
-  { cfgDir :: FilePath,
-    logDir :: FilePath,
-    iniFile :: FilePath,
-    storeLogFile :: FilePath,
-    caKeyFile :: FilePath,
-    caCrtFile :: FilePath,
-    serverKeyFile :: FilePath,
-    serverCrtFile :: FilePath,
-    fingerprintFile :: FilePath,
-    defaultServerPort :: ServiceName,
-    executableName :: String,
-    serverVersion :: String,
-    mkIniFile :: Bool -> ServiceName -> String,
-    mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
-  }
-
-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"
-
-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 <*> cliCommandP cliCfg)
-        (header version <> fullDesc)
-    )
-  where
-    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
-    version = serverVersion cliCfg
-
-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
-    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 caCrtFile
-      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
-      pure fp
-
-    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,
-    port :: ServiceName,
-    enableWebsockets :: Bool
-  }
-
-mkIniOptions :: Ini -> IniOptions
-mkIniOptions ini =
-  IniOptions
-    { enableStoreLog = (== "on") $ strictIni "STORE_LOG" "enable" ini,
-      port = T.unpack $ strictIni "TRANSPORT" "port" ini,
-      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
-    }
-
-strictIni :: String -> String -> Ini -> T.Text
-strictIni section key ini =
-  fromRight (error ("no key " <> key <> " in section " <> section)) $
-    lookupValue (T.pack section) (T.pack key) ini
-
-readStrictIni :: Read a => String -> String -> Ini -> a
-readStrictIni section key = read . T.unpack . strictIni section key
-
-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
-    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
-
-    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 <> ")..."
-
-cleanup :: ServerCLIConfig cfg -> IO ()
-cleanup ServerCLIConfig {cfgDir, logDir} = do
-  deleteDirIfExists cfgDir
-  deleteDirIfExists logDir
-  where
-    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
-
-printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
-printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
-  putStrLn serverVersion
-  B.putStrLn $ "Fingerprint: " <> strEncode fpStr

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -12,27 +11,19 @@ import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-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)
 import qualified Network.TLS as T
 import Numeric.Natural
 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 (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
 import System.IO (IOMode (..))
-import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
@@ -42,40 +33,13 @@ data ServerConfig = ServerConfig
     msgQueueQuota :: Natural,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    storeLogFile :: Maybe FilePath,
-    storeMsgsFile :: Maybe FilePath,
-    -- | set to False to prohibit creating new queues
-    allowNewQueues :: Bool,
-    -- | 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),
-    -- and check interval, seconds
-    inactiveClientExpiration :: Maybe ExpirationConfig,
-    -- | log SMP server usage statistics, only aggregates are logged, seconds
-    logStatsInterval :: Maybe Int,
-    -- | 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,
-    -- | CA certificate private key is not needed for initialization
+    storeLog :: Maybe (StoreLog 'ReadMode),
+    -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath
   }
 
-defaultMessageExpiration :: ExpirationConfig
-defaultMessageExpiration =
-  ExpirationConfig
-    { ttl = 30 * 86400, -- seconds, 30 days
-      checkInterval = 43200 -- seconds, 12 hours
-    }
-
-defaultInactiveClientExpiration :: ExpirationConfig
-defaultInactiveClientExpiration =
-  ExpirationConfig
-    { ttl = 86400, -- seconds, 24 hours
-      checkInterval = 43200 -- seconds, 12 hours
-    }
-
 data Env = Env
   { config :: ServerConfig,
     server :: Server,
@@ -84,40 +48,26 @@ data Env = Env
     msgStore :: STMMsgStore,
     idsDrg :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    tlsServerParams :: T.ServerParams,
-    serverStats :: ServerStats
+    tlsServerParams :: T.ServerParams
   }
 
 data Server = Server
   { subscribedQ :: TBQueue (RecipientId, Client),
-    subscribers :: TMap RecipientId Client,
+    subscribers :: TVar (Map RecipientId Client),
     ntfSubscribedQ :: TBQueue (NotifierId, Client),
-    notifiers :: TMap NotifierId Client
+    notifiers :: TVar (Map NotifierId Client)
   }
 
 data Client = Client
-  { subscriptions :: TMap RecipientId Sub,
-    ntfSubscriptions :: TMap NotifierId (),
+  { subscriptions :: TVar (Map RecipientId Sub),
+    ntfSubscriptions :: TVar (Map NotifierId ()),
     rcvQ :: TBQueue (Transmission Cmd),
     sndQ :: TBQueue (Transmission BrokerMsg),
     sessionId :: ByteString,
-    connected :: TVar Bool,
-    activeAt :: TVar SystemTime
+    connected :: TVar Bool
   }
 
-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)
+data SubscriptionThread = NoSub | SubPending | SubThread ThreadId
 
 data Sub = Sub
   { subThread :: SubscriptionThread,
@@ -127,33 +77,19 @@ data Sub = Sub
 newServer :: Natural -> STM Server
 newServer qSize = do
   subscribedQ <- newTBQueue qSize
-  subscribers <- TM.empty
+  subscribers <- newTVar M.empty
   ntfSubscribedQ <- newTBQueue qSize
-  notifiers <- TM.empty
+  notifiers <- newTVar M.empty
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
-newClient :: Natural -> ByteString -> SystemTime -> STM Client
-newClient qSize sessionId ts = do
-  subscriptions <- TM.empty
-  ntfSubscriptions <- TM.empty
+newClient :: Natural -> ByteString -> STM Client
+newClient qSize sessionId = do
+  subscriptions <- newTVar M.empty
+  ntfSubscriptions <- newTVar M.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  activeAt <- newTVar ts
-  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}
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected}
 
 newSubscription :: STM Sub
 newSubscription = do
@@ -161,26 +97,27 @@ newSubscription = do
   return Sub {subThread = NoSub, delivered}
 
 newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
-newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
+newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do
   server <- atomically $ newServer (serverTbqSize config)
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
-  s' <- restoreQueues queueStore `mapM` storeLog
+  s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   let serverIdentity = KeyHash fp
-  serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
-  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams, serverStats}
+  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams}
   where
     restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
-    restoreQueues QueueStore {queues, senders, notifiers} s = do
-      (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
+    restoreQueues queueStore s = do
+      (queues, s') <- liftIO $ readWriteStoreLog s
+      atomically $
+        modifyTVar queueStore $ \d ->
+          d
+            { queues,
+              senders = M.foldr' addSender M.empty queues,
+              notifiers = M.foldr' addNotifier M.empty queues
+            }
       pure s'
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)

src/Simplex/Messaging/Server/Expiration.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Server.Expiration where
-
-import Control.Monad.IO.Class
-import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-
-data ExpirationConfig = ExpirationConfig
-  { -- time after which the entity can be expired, seconds
-    ttl :: Int64,
-    -- interval to check expiration, seconds
-    checkInterval :: Int
-  }
-
-expireBeforeEpoch :: ExpirationConfig -> IO Int64
-expireBeforeEpoch ExpirationConfig {ttl} = subtract ttl . systemSeconds <$> liftIO getSystemTime

src/Simplex/Messaging/Server/MsgStore.hs

@@ -1,12 +1,9 @@
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
-import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime)
 import Numeric.Natural
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)
 
 data Message = Message
@@ -15,22 +12,9 @@ data Message = Message
     msgBody :: MsgBody
   }
 
-instance StrEncoding Message where
-  strEncode Message {msgId, ts, msgBody} = strEncode (msgId, ts, msgBody)
-  strP = do
-    (msgId, ts, msgBody) <- strP
-    pure Message {msgId, ts, msgBody}
-
-data MsgLogRecord = MsgLogRecord RecipientId Message
-
-instance StrEncoding MsgLogRecord where
-  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
@@ -38,4 +22,3 @@ class MonadMsgQueue q m where
   tryPeekMsg :: q -> m (Maybe Message) -- non blocking
   peekMsg :: q -> m Message -- blocking
   tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available
-  deleteExpiredMsgs :: q -> Int64 -> m ()

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

@@ -3,42 +3,39 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
-import Control.Concurrent.STM.TBQueue (flushTBQueue)
-import Control.Monad (when)
-import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime (systemSeconds))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Numeric.Natural
 import Simplex.Messaging.Protocol (RecipientId)
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import UnliftIO.STM
 
 newtype MsgQueue = MsgQueue {msgQueue :: TBQueue Message}
 
-type STMMsgStore = TMap RecipientId MsgQueue
+newtype MsgStoreData = MsgStoreData {messages :: Map RecipientId MsgQueue}
+
+type STMMsgStore = TVar MsgStoreData
 
 newMsgStore :: STM STMMsgStore
-newMsgStore = TM.empty
+newMsgStore = newTVar $ MsgStoreData M.empty
 
 instance MonadMsgStore STMMsgStore MsgQueue STM where
   getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
-  getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
+  getMsgQueue store rId quota = do
+    m <- messages <$> readTVar store
+    maybe (newQ m) return $ M.lookup rId m
     where
-      newQ = do
+      newQ m' = do
         q <- MsgQueue <$> newTBQueue quota
-        TM.insert rId q st
+        writeTVar store . MsgStoreData $ M.insert rId q m'
         return q
 
   delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-  delMsgQueue st rId = TM.delete rId st
-
-  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
-  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
+  delMsgQueue store rId =
+    modifyTVar store $ MsgStoreData . M.delete rId . messages
 
 instance MonadMsgQueue MsgQueue STM where
   isFull :: MsgQueue -> STM Bool
@@ -56,11 +53,3 @@ instance MonadMsgQueue MsgQueue STM where
   -- atomic delete (== read) last and peek next message if available
   tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
   tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q
-
-  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

@@ -15,7 +15,6 @@ data QueueRec = QueueRec
     notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
     status :: QueueStatus
   }
-  deriving (Eq, Show)
 
 data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
 

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,82 +11,107 @@
 
 module Simplex.Messaging.Server.QueueStore.STM where
 
-import Control.Monad
-import Data.Functor (($>))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, ($>>=))
 import UnliftIO.STM
 
-data QueueStore = QueueStore
-  { queues :: TMap RecipientId (TVar QueueRec),
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId
+data QueueStoreData = QueueStoreData
+  { queues :: Map RecipientId QueueRec,
+    senders :: Map SenderId RecipientId,
+    notifiers :: Map NotifierId RecipientId
   }
 
+type QueueStore = TVar QueueStoreData
+
 newQueueStore :: STM QueueStore
-newQueueStore = do
-  queues <- TM.empty
-  senders <- TM.empty
-  notifiers <- TM.empty
-  pure QueueStore {queues, senders, notifiers}
+newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty}
 
 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
+  addQueue store qRec@QueueRec {recipientId = rId, senderId = sId} = do
+    cs@QueueStoreData {queues, senders} <- readTVar store
+    if M.member rId queues || M.member sId senders
+      then return $ Left DUPLICATE_
+      else do
+        writeTVar store $
+          cs
+            { queues = M.insert rId qRec queues,
+              senders = M.insert sId rId senders
+            }
+        return $ Right ()
 
   getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
-  getQueue QueueStore {queues, senders, notifiers} party qId =
-    toResult <$> (mapM readTVar =<< getVar)
+  getQueue st party qId = do
+    cs <- readTVar st
+    pure $ case party of
+      SRecipient -> getRcpQueue cs qId
+      SSender -> getPartyQueue cs senders
+      SNotifier -> getPartyQueue cs notifiers
     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)
+      getPartyQueue ::
+        QueueStoreData ->
+        (QueueStoreData -> Map QueueId RecipientId) ->
+        Either ErrorType QueueRec
+      getPartyQueue cs recipientIds =
+        case M.lookup qId $ recipientIds cs of
+          Just rId -> getRcpQueue cs rId
+          Nothing -> Left AUTH
 
   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
+  secureQueue store rId sKey =
+    updateQueues store rId $ \cs c ->
+      case senderKey c of
+        Just _ -> (Left AUTH, cs)
+        _ -> (Right c, cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})
 
   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
+  addQueueNotifier store rId nId nKey = do
+    cs@QueueStoreData {queues, notifiers} <- readTVar store
+    if M.member nId notifiers
+      then pure $ Left DUPLICATE_
+      else case M.lookup rId queues of
+        Nothing -> pure $ Left AUTH
+        Just q -> case notifier q of
+          Just _ -> pure $ Left AUTH
           _ -> do
-            writeTVar qVar q {notifier = Just (nId, nKey)}
-            TM.insert nId rId notifiers
-            pure $ Just q
+            writeTVar store $
+              cs
+                { queues = M.insert rId q {notifier = Just (nId, nKey)} queues,
+                  notifiers = M.insert nId rId notifiers
+                }
+            pure $ Right q
 
   suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  suspendQueue QueueStore {queues} rId =
-    withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
+  suspendQueue store rId =
+    updateQueues store rId $ \cs c ->
+      (Right (), cs {queues = M.insert rId c {status = QueueOff} (queues cs)})
 
   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
+  deleteQueue store rId =
+    updateQueues store rId $ \cs c ->
+      ( Right (),
+        cs
+          { queues = M.delete rId (queues cs),
+            senders = M.delete (senderId c) (senders cs)
+          }
+      )
 
-toResult :: Maybe a -> Either ErrorType a
-toResult = maybe (Left AUTH) Right
+updateQueues ::
+  QueueStore ->
+  RecipientId ->
+  (QueueStoreData -> QueueRec -> (Either ErrorType a, QueueStoreData)) ->
+  STM (Either ErrorType a)
+updateQueues store rId update = do
+  cs <- readTVar store
+  let conn = getRcpQueue cs rId
+  either (return . Left) (_update cs) conn
+  where
+    _update cs c = do
+      let (res, cs') = update cs c
+      writeTVar store cs'
+      return res
 
-withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
-withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
+getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
+getRcpQueue cs rId = maybe (Left AUTH) Right . M.lookup rId $ queues cs

src/Simplex/Messaging/TMap.hs

@@ -1,82 +0,0 @@
-module Simplex.Messaging.TMap
-  ( TMap,
-    empty,
-    singleton,
-    Simplex.Messaging.TMap.null,
-    Simplex.Messaging.TMap.lookup,
-    member,
-    insert,
-    delete,
-    lookupInsert,
-    lookupDelete,
-    adjust,
-    update,
-    alter,
-    alterF,
-    union,
-  )
-where
-
-import Control.Concurrent.STM
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-
-type TMap k a = TVar (Map k a)
-
-empty :: STM (TMap k a)
-empty = newTVar M.empty
-{-# INLINE empty #-}
-
-singleton :: k -> a -> STM (TMap k a)
-singleton k v = newTVar $ M.singleton k v
-{-# INLINE singleton #-}
-
-null :: TMap k a -> STM Bool
-null m = M.null <$> readTVar m
-{-# INLINE null #-}
-
-lookup :: Ord k => k -> TMap k a -> STM (Maybe a)
-lookup k m = M.lookup k <$> readTVar m
-{-# INLINE lookup #-}
-
-member :: Ord k => k -> TMap k a -> STM Bool
-member k m = M.member k <$> readTVar m
-{-# INLINE member #-}
-
-insert :: Ord k => k -> a -> TMap k a -> STM ()
-insert k v m = modifyTVar' m $ M.insert k v
-{-# INLINE insert #-}
-
-delete :: Ord k => k -> TMap k a -> STM ()
-delete k m = modifyTVar' m $ M.delete k
-{-# INLINE delete #-}
-
-lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a)
-lookupInsert k v m = stateTVar m $ \mv -> (M.lookup k mv, M.insert k v mv)
-{-# INLINE lookupInsert #-}
-
-lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
-lookupDelete k m = stateTVar m $ \mv -> (M.lookup k mv, M.delete k mv)
-{-# INLINE lookupDelete #-}
-
-adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM ()
-adjust f k m = modifyTVar' m $ M.adjust f k
-{-# INLINE adjust #-}
-
-update :: Ord k => (a -> Maybe a) -> k -> TMap k a -> STM ()
-update f k m = modifyTVar' m $ M.update f k
-{-# INLINE update #-}
-
-alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM ()
-alter f k m = modifyTVar' m $ M.alter f k
-{-# INLINE alter #-}
-
-alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM ()
-alterF f k m = do
-  mv <- M.alterF f k =<< readTVar m
-  writeTVar m $! mv
-{-# INLINE alterF #-}
-
-union :: Ord k => Map k a -> TMap k a -> STM ()
-union m' m = modifyTVar' m $ M.union m'
-{-# INLINE union #-}

src/Simplex/Messaging/Transport.hs

@@ -26,6 +26,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
 module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
+    smpBlockSize,
     supportedSMPVersions,
     simplexMQVersion,
 
@@ -37,7 +38,6 @@ module Simplex.Messaging.Transport
 
     -- * TLS Transport
     TLS (..),
-    SessionId,
     connectTLS,
     closeTLS,
     supportedParameters,
@@ -46,8 +46,8 @@ module Simplex.Messaging.Transport
     -- * SMP transport
     THandle (..),
     TransportError (..),
-    smpServerHandshake,
-    smpClientHandshake,
+    serverHandshake,
+    clientHandshake,
     tPutBlock,
     tGetBlock,
     serializeTransportError,
@@ -80,7 +80,7 @@ import qualified Network.TLS.Extra as TE
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
-import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
+import Simplex.Messaging.Util (bshow)
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 import UnliftIO.Exception (Exception)
@@ -96,7 +96,7 @@ supportedSMPVersions :: VersionRange
 supportedSMPVersions = mkVersionRange 1 1
 
 simplexMQVersion :: String
-simplexMQVersion = "2.3.1"
+simplexMQVersion = "1.0.2"
 
 -- * Transport connection class
 
@@ -115,7 +115,7 @@ class Transport c where
   getClientConnection :: T.Context -> IO c
 
   -- | tls-unique channel binding per RFC5929
-  tlsUnique :: c -> SessionId
+  tlsUnique :: c -> ByteString
 
   -- | Close connection
   closeConnection :: c -> IO ()
@@ -154,7 +154,7 @@ 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
+      `E.catch` \(e :: E.SomeException) -> putStrLn ("exception: " <> show e) >> E.throwIO e
     pure ctx
 
 getTLS :: TransportPeer -> T.Context -> IO TLS
@@ -175,9 +175,8 @@ withTlsUnique peer cxt f =
 
 closeTLS :: T.Context -> IO ()
 closeTLS ctx =
-  T.bye ctx -- sometimes socket was closed before 'TLS.bye' so we catch the 'Broken pipe' error here
-    `E.finally` T.contextClose ctx
-    `catchAll_` pure ()
+  (T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'
+    `E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here
 
 supportedParameters :: T.Supported
 supportedParameters =
@@ -214,11 +213,10 @@ instance Transport TLS where
       readChunks :: ByteString -> IO ByteString
       readChunks b
         | B.length b >= n = pure b
-        | otherwise =
-          T.recvData tlsContext >>= \case
-            -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-            "" -> ioe_EOF
-            s -> readChunks $ b <> s
+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
+        e -> E.throwIO e
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -252,18 +250,14 @@ trimCR s = if B.last s == '\r' then B.init s else s
 -- | The handle for SMP encrypted transport connection over Transport .
 data THandle c = THandle
   { connection :: c,
-    sessionId :: SessionId,
-    blockSize :: Int,
-    -- | agreed server protocol version
-    thVersion :: Version
+    sessionId :: ByteString,
+    -- | agreed SMP server protocol version
+    smpVersion :: Version
   }
 
--- | TLS-unique channel binding
-type SessionId = ByteString
-
 data ServerHandshake = ServerHandshake
   { smpVersionRange :: VersionRange,
-    sessionId :: SessionId
+    sessionId :: ByteString
   }
 
 data ClientHandshake = ClientHandshake
@@ -338,45 +332,45 @@ serializeTransportError = \case
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
-tPutBlock THandle {connection = c, blockSize} block =
+tPutBlock THandle {connection = c} block =
   bimapM (const $ pure TELargeMsg) (cPut c) $
-    C.pad block blockSize
+    C.pad block smpBlockSize
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} =
-  cGet c blockSize >>= \case
+tGetBlock THandle {connection = c} =
+  cGet c smpBlockSize >>= \case
     "" -> ioe_EOF
     msg -> pure . first (const TELargeMsg) $ C.unPad msg
 
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-smpServerHandshake c kh = do
-  let th@THandle {sessionId} = smpTHandle c
+serverHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+serverHandshake c kh = do
+  let th@THandle {sessionId} = tHandle c
   sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
   getHandshake th >>= \case
     ClientHandshake {smpVersion, keyHash}
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
       | smpVersion `isCompatible` supportedSMPVersions -> do
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure (th :: THandle c) {smpVersion}
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-smpClientHandshake c keyHash = do
-  let th@THandle {sessionId} = smpTHandle c
+clientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+clientHandshake c keyHash = do
+  let th@THandle {sessionId} = tHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
   if sessionId /= sessId
     then throwE TEBadSession
     else case smpVersionRange `compatibleVersion` supportedSMPVersions of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure (th :: THandle c) {smpVersion}
       Nothing -> throwE $ TEHandshake VERSION
 
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
@@ -385,5 +379,6 @@ sendHandshake th = ExceptT . tPutBlock th . smpEncode
 getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
 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}
+tHandle :: Transport c => c -> THandle c
+tHandle c =
+  THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0}

src/Simplex/Messaging/Transport/Client.hs

@@ -1,10 +1,8 @@
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Client
   ( runTransportClient,
-    runTLSTransportClient,
-    smpClientHandshake,
+    clientHandshake,
   )
 where
 
@@ -22,23 +20,19 @@ import Network.Socket
 import qualified Network.TLS as T
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.KeepAlive
 import System.IO.Error
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
 -- | Connect to passed TCP host:port and pass handle to the client.
-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 -> 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
+runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> (c -> m a) -> m a
+runTransportClient host port keyHash client = do
+  let clientParams = mkTLSClientParams host port keyHash
+  c <- liftIO $ startTCPClient host port clientParams
   client c `E.finally` liftIO (closeConnection c)
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
-startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c
+startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -57,19 +51,16 @@ startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      mapM_ (setSocketKeepAlive sock) keepAliveOpts
       ctx <- connectTLS clientParams sock
       getClientConnection ctx
 
--- 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
+mkTLSClientParams :: HostName -> ServiceName -> C.KeyHash -> T.ClientParams
+mkTLSClientParams host port keyHash = do
   let p = B.pack port
   (T.defaultParamsClient host p)
-    { T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
-      T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
-      T.clientSupported = supported
+    { T.clientShared = def,
+      T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p},
+      T.clientSupported = supportedParameters
     }
 
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -1,36 +0,0 @@
-module Simplex.Messaging.Transport.HTTP2 where
-
-import qualified Control.Exception as E
-import Data.Default (def)
-import Foreign (mallocBytes)
-import Network.HPACK (BufferSize)
-import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
-import qualified Network.TLS as T
-import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
-import qualified System.TimeManager as TI
-
-withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
-withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
-
-allocTlsConfig :: TLS -> BufferSize -> IO Config
-allocTlsConfig c sz = do
-  buf <- mallocBytes sz
-  tm <- TI.initialize $ 30 * 1000000
-  pure
-    Config
-      { confWriteBuffer = buf,
-        confBufferSize = sz,
-        confSendAll = cPut c,
-        confReadN = cGet c,
-        confPositionReadMaker = defaultPositionReadMaker,
-        confTimeoutManager = tm
-      }
-
-http2TLSParams :: T.Supported
-http2TLSParams =
-  def
-    { T.supportedVersions = [T.TLS13, T.TLS12],
-      T.supportedCiphers = TE.ciphersuite_strong_det,
-      T.supportedSecureRenegotiation = False
-    }

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

@@ -1,128 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Transport.HTTP2.Client where
-
-import Control.Concurrent.Async
-import Control.Exception (IOException)
-import qualified Control.Exception as E
-import Control.Monad.Except
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Maybe (isNothing)
-import qualified Data.X509.CertificateStore as XS
-import Network.HPACK (HeaderTable)
-import Network.HTTP2.Client (ClientConfig (..), Request, Response)
-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 (runTLSTransportClient)
-import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
-import UnliftIO.STM
-import UnliftIO.Timeout
-
-data HTTP2Client = HTTP2Client
-  { action :: Async (),
-    connected :: TVar Bool,
-    host :: HostName,
-    port :: ServiceName,
-    config :: HTTP2ClientConfig,
-    reqQ :: TBQueue (Request, TMVar HTTP2Response)
-  }
-
-data HTTP2Response = HTTP2Response
-  { response :: Response,
-    respBody :: ByteString,
-    respTrailers :: Maybe HeaderTable
-  }
-
-data HTTP2ClientConfig = HTTP2ClientConfig
-  { qSize :: Natural,
-    connTimeout :: Int,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    caStoreFile :: FilePath,
-    suportedTLSParams :: T.Supported
-  }
-  deriving (Show)
-
-defaultHTTP2ClientConfig :: HTTP2ClientConfig
-defaultHTTP2ClientConfig =
-  HTTP2ClientConfig
-    { qSize = 64,
-      connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
-      caStoreFile = "/etc/ssl/cert.pem",
-      suportedTLSParams = http2TLSParams
-    }
-
-data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
-  deriving (Show)
-
-getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
-  (atomically mkHTTPS2Client >>= runClient)
-    `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
-  where
-    mkHTTPS2Client :: STM HTTP2Client
-    mkHTTPS2Client = do
-      connected <- newTVar False
-      reqQ <- newTBQueue $ qSize config
-      pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
-
-    runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
-    runClient c = do
-      cVar <- newEmptyTMVarIO
-      caStore <- XS.readCertificateStore caStoreFile
-      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
-      action <-
-        async $
-          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 (Left e) -> Left e
-        Nothing -> Left HCNetworkError1
-
-    client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    client c cVar sendReq = do
-      atomically $ do
-        writeTVar (connected c) True
-        putTMVar cVar $ Right ()
-      process c sendReq `E.finally` disconnected
-
-    process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    process HTTP2Client {reqQ} sendReq = forever $ do
-      (req, respVar) <- atomically $ readTBQueue reqQ
-      sendReq req $ \r -> do
-        let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
-        respBody <- getResponseBody r ""
-        respTrailers <- H.getResponseTrailers r
-        writeResp respBody respTrailers
-
-    getResponseBody :: Response -> ByteString -> IO ByteString
-    getResponseBody r s =
-      H.getResponseBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getResponseBody r $ s <> chunk
-
--- | Disconnects client from the server and terminates client threads.
-closeHTTP2Client :: HTTP2Client -> IO ()
--- TODO disconnect
-closeHTTP2Client = uninterruptibleCancel . action
-
-sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
-sendRequest HTTP2Client {reqQ, config} req = do
-  resp <- newEmptyTMVarIO
-  atomically $ writeTBQueue reqQ (req, resp)
-  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
-
-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

@@ -1,70 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Transport.HTTP2.Server where
-
-import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
-import Control.Concurrent.STM
-import Control.Monad
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Network.HPACK (HeaderTable)
-import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
-import qualified Network.HTTP2.Server as H
-import Network.Socket
-import qualified Network.TLS as T
-import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
-import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
-
-type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
-
-data HTTP2ServerConfig = HTTP2ServerConfig
-  { qSize :: Natural,
-    http2Port :: ServiceName,
-    serverSupported :: T.Supported,
-    caCertificateFile :: FilePath,
-    privateKeyFile :: FilePath,
-    certificateFile :: FilePath
-  }
-  deriving (Show)
-
-data HTTP2Request = HTTP2Request
-  { request :: Request,
-    reqBody :: ByteString,
-    reqTrailers :: Maybe HeaderTable,
-    sendResponse :: Response -> IO ()
-  }
-
-data HTTP2Server = HTTP2Server
-  { action :: Async (),
-    reqQ :: TBQueue HTTP2Request
-  }
-
-getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-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 $ \r sendResponse -> do
-      reqBody <- getRequestBody r ""
-      reqTrailers <- H.getRequestTrailers r
-      atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
-  void . atomically $ takeTMVar started
-  pure HTTP2Server {action, reqQ}
-  where
-    getRequestBody :: Request -> ByteString -> IO ByteString
-    getRequestBody r s =
-      H.getRequestBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getRequestBody r $ s <> chunk
-
-closeHTTP2Server :: HTTP2Server -> IO ()
-closeHTTP2Server = uninterruptibleCancel . action
-
-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,63 +0,0 @@
-{-# LANGUAGE CApiFFI #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Transport.KeepAlive where
-
-import Foreign.C (CInt (..))
-import Network.Socket
-
-data KeepAliveOpts = KeepAliveOpts
-  { keepIdle :: Int,
-    keepIntvl :: Int,
-    keepCnt :: Int
-  }
-  deriving (Show)
-
-defaultKeepAliveOpts :: KeepAliveOpts
-defaultKeepAliveOpts =
-  KeepAliveOpts
-    { keepIdle = 30,
-      keepIntvl = 15,
-      keepCnt = 4
-    }
-
-_SOL_TCP :: CInt
-_SOL_TCP = 6
-
-#if defined(mingw32_HOST_OS)
--- Windows
-
--- The values are copied from windows::Win32::Networking::WinSock
--- https://microsoft.github.io/windows-docs-rs/doc/windows/Win32/Networking/WinSock/index.html
-
-_TCP_KEEPIDLE :: CInt
-_TCP_KEEPIDLE = 3
-
-_TCP_KEEPINTVL :: CInt
-_TCP_KEEPINTVL = 17
-
-_TCP_KEEPCNT :: CInt
-_TCP_KEEPCNT = 16
-
-#else
--- Mac/Linux
-
-#if defined(darwin_HOST_OS)
-foreign import capi "netinet/tcp.h value TCP_KEEPALIVE" _TCP_KEEPIDLE :: CInt
-#else
-foreign import capi "netinet/tcp.h value TCP_KEEPIDLE" _TCP_KEEPIDLE :: CInt
-#endif
-
-foreign import capi "netinet/tcp.h value TCP_KEEPINTVL" _TCP_KEEPINTVL :: CInt
-
-foreign import capi "netinet/tcp.h value TCP_KEEPCNT" _TCP_KEEPCNT :: CInt
-
-#endif
-
-setSocketKeepAlive :: Socket -> KeepAliveOpts -> IO ()
-setSocketKeepAlive sock KeepAliveOpts {keepCnt, keepIdle, keepIntvl} = do
-  setSocketOption sock KeepAlive 1
-  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPIDLE) keepIdle
-  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPINTVL) keepIntvl
-  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPCNT) keepCnt

src/Simplex/Messaging/Transport/Server.hs

@@ -4,30 +4,25 @@
 
 module Simplex.Messaging.Transport.Server
   ( runTransportServer,
-    runTCPServer,
-    loadSupportedTLSServerParams,
     loadTLSServerParams,
     loadFingerprint,
-    smpServerHandshake,
+    serverHandshake,
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX
 import Data.Default (def)
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_)
 import System.Exit (exitFailure)
-import System.Mem.Weak (Weak, deRefWeak)
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -38,32 +33,27 @@ import UnliftIO.STM
 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 ->
+  liftIO $ do
+    clients <- newTVarIO S.empty
     E.bracket
-      (connectTLS serverParams conn >>= getServerConnection)
-      closeConnection
-      (unliftIO u . server)
-
--- | Run TCP server without TLS
-runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
-runTCPServer started port server = do
-  clients <- atomically TM.empty
-  clientId <- newTVarIO 0
-  E.bracket
-    (startTCPServer started port)
-    (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 -> (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
-
-closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
-closeServer started clients sock = do
-  readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
-  close sock
-  void . atomically $ tryPutTMVar started False
+      (startTCPServer started port)
+      (closeServer clients)
+      $ \sock -> forever $ do
+        (connSock, _) <- accept sock
+        tid <- forkIO $ connectClient u connSock `E.catch` \(_ :: E.SomeException) -> pure ()
+        atomically . modifyTVar clients $ S.insert tid
+  where
+    connectClient :: UnliftIO m -> Socket -> IO ()
+    connectClient u connSock =
+      E.bracket
+        (connectTLS serverParams connSock >>= getServerConnection)
+        closeConnection
+        (unliftIO u . server)
+    closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
+    closeServer clients sock = do
+      readTVarIO clients >>= mapM_ killThread
+      close sock
+      void . atomically $ tryPutTMVar started False
 
 startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
 startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
@@ -81,10 +71,7 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
     setStarted sock = atomically (tryPutTMVar started True) >> pure sock
 
 loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
-loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
-
-loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
-loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
+loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
   fromCredential <$> loadServerCredential
   where
     loadServerCredential :: IO T.Credential
@@ -98,7 +85,7 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p
         { T.serverWantClientCert = False,
           T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
           T.serverHooks = def,
-          T.serverSupported = serverSupported
+          T.serverSupported = supportedParameters
         }
 
 loadFingerprint :: FilePath -> IO Fingerprint

src/Simplex/Messaging/Util.hs

@@ -1,9 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Util where
 
-import qualified Control.Exception as E
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
@@ -60,21 +58,6 @@ 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 #-}
 
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM b a = ifM b a $ pure ()
-{-# INLINE whenM #-}
-
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM b = ifM b $ pure ()
 {-# INLINE unlessM #-}
-
-($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
-f $>>= g = f >>= fmap join . mapM g
-
-catchAll :: IO a -> (E.SomeException -> IO a) -> IO a
-catchAll = E.catch
-{-# INLINE catchAll #-}
-
-catchAll_ :: IO a -> IO a -> IO a
-catchAll_ a = catchAll a . const
-{-# INLINE catchAll_ #-}

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.28
+resolver: lts-18.21
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -36,9 +36,9 @@ packages:
 #
 extra-deps:
   - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
-  - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987 # below dependancies are to update Aeson to 2.0.3
+  - tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
+# 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
@@ -52,6 +52,7 @@ extra-deps:
   #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e
   #   subdirs:
   #     - core
+
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

tests/AgentTests.hs

@@ -13,14 +13,14 @@ import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
 import AgentTests.SQLiteTests (storeTests)
-import AgentTests.SchemaDump (schemaDumpTest)
+import AgentTests.PostgresTests (postgresStoreTests)
 import Control.Concurrent
 import Control.Monad (forM_)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
-import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
+import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Encoding.String
@@ -37,7 +37,7 @@ agentTests (ATransport t) = do
   describe "Double ratchet tests" doubleRatchetTests
   describe "Functional API" $ functionalAPITests (ATransport t)
   describe "SQLite store" storeTests
-  describe "SQLite schema dump" schemaDumpTest
+  describe "Postgres store" postgresStoreTests
   describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection" $ do
     it "should connect via one server and one agent" $
@@ -64,11 +64,9 @@ agentTests (ATransport t) = do
       smpAgentTest3_1_1 $ testSubscription t
     it "should send notifications to client when server disconnects" $
       smpAgentServerTest $ testSubscrNotification t
-  describe "Message delivery and server reconnection" $ do
+  describe "Message delivery" $ do
     it "should deliver messages after losing server connection and re-connecting" $
       smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
-    it "should connect to the server when server goes up if it initially was down" $
-      smpAgentTestN [] $ testServerConnectionAfterError t
     it "should deliver pending messages after agent restarting" $
       smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
     it "should concurrently deliver messages to connections without blocking" $
@@ -130,25 +128,25 @@ testDuplexConnection _ alice bob = do
   bob <# ("", "alice", CON)
   alice <# ("", "bob", CON)
   -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
-  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 5)
-  alice <# ("", "bob", SENT 5)
+  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 4)
+  alice <# ("", "bob", SENT 4)
   bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-  bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
-  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 6)
-  alice <# ("", "bob", SENT 6)
+  bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
+  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 5)
+  alice <# ("", "bob", SENT 5)
   bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
-  bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 7)
-  bob <# ("", "alice", SENT 7)
+  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
-  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 8)
-  bob <# ("", "alice", SENT 8)
+  alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
+  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 7)
+  bob <# ("", "alice", SENT 7)
   alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
-  alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
+  alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
-  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 9)
-  bob <# ("", "alice", MERR 9 (SMP AUTH))
+  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 8)
+  bob <# ("", "alice", MERR 8 (SMP AUTH))
   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
   alice #:# "nothing else should be delivered to alice"
 
@@ -163,25 +161,25 @@ testDuplexConnRandomIds _ alice bob = do
   bob <# ("", aliceConn, INFO "alice's connInfo")
   bob <# ("", aliceConn, CON)
   alice <# ("", bobConn, CON)
-  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 5)
-  alice <# ("", bobConn, SENT 5)
+  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 4)
+  alice <# ("", bobConn, SENT 4)
   bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
-  bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
-  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 6)
-  alice <# ("", bobConn, SENT 6)
+  bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
+  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 5)
+  alice <# ("", bobConn, SENT 5)
   bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
-  bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
-  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 7)
-  bob <# ("", aliceConn, SENT 7)
+  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
+  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 6)
+  bob <# ("", aliceConn, SENT 6)
   alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
-  alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
-  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 8)
-  bob <# ("", aliceConn, SENT 8)
+  alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
+  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 7)
+  bob <# ("", aliceConn, SENT 7)
   alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
-  alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
+  alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
   alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
-  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 9)
-  bob <# ("", aliceConn, MERR 9 (SMP AUTH))
+  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 8)
+  bob <# ("", aliceConn, MERR 8 (SMP AUTH))
   alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
   alice #:# "nothing else should be delivered to alice"
 
@@ -198,10 +196,10 @@ testContactConnection _ alice bob tom = do
   alice <# ("", "bob", INFO "bob's connInfo 2")
   alice <# ("", "bob", CON)
   bob <# ("", "alice", CON)
-  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 5)
-  alice <# ("", "bob", SENT 5)
+  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 4)
+  alice <# ("", "bob", SENT 4)
   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
-  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
+  bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
   tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
   ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
@@ -211,10 +209,10 @@ testContactConnection _ alice bob tom = do
   alice <# ("", "tom", INFO "tom's connInfo 2")
   alice <# ("", "tom", CON)
   tom <# ("", "alice", CON)
-  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 5)
-  alice <# ("", "tom", SENT 5)
+  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 4)
+  alice <# ("", "tom", SENT 4)
   tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
-  tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
+  tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
 
 testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testContactConnRandomIds _ alice bob = do
@@ -234,10 +232,10 @@ testContactConnRandomIds _ alice bob = do
   alice <# ("", bobConn, CON)
   bob <# ("", aliceConn, CON)
 
-  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 5)
-  alice <# ("", bobConn, SENT 5)
+  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 4)
+  alice <# ("", bobConn, SENT 4)
   bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
-  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
+  bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
 testRejectContactRequest _ alice bob = do
@@ -254,20 +252,20 @@ testRejectContactRequest _ alice bob = do
 testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testSubscription _ alice1 alice2 bob = do
   (alice1, "alice") `connect` (bob, "bob")
-  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 5)
-  bob <# ("", "alice", SENT 5)
+  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 4)
+  bob <# ("", "alice", SENT 4)
   alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
-  alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
-  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 6)
-  bob <# ("", "alice", SENT 6)
+  alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
+  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 5)
+  bob <# ("", "alice", SENT 5)
   alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-  alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
+  alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
   alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
   alice1 <# ("", "bob", END)
-  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 7)
-  bob <# ("", "alice", SENT 7)
+  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
   alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-  alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
+  alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
   alice1 #:# "nothing else should be delivered to alice1"
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
@@ -275,7 +273,7 @@ testSubscrNotification t (server, _) client = do
   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"])
+  client <# ("", "conn1", DOWN)
   withSmpServer (ATransport t) $
     client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
 
@@ -283,80 +281,40 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
 testMsgDeliveryServerRestart t alice bob = do
   withServer $ do
     connect (alice, "alice") (bob, "bob")
-    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 5)
-    bob <# ("", "alice", SENT 5)
+    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 4)
+    bob <# ("", "alice", SENT 4)
     alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-    alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
+    alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
-  let server = (SMPServer "localhost" testPort2 testKeyHash)
-  alice <# ("", "", DOWN server ["bob"])
-  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 6)
+  alice <# ("", "bob", DOWN)
+  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 5)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
-    bob <# ("", "alice", SENT 6)
-    alice <# ("", "", UP server ["bob"])
+    bob <# ("", "alice", SENT 5)
+    alice <# ("", "bob", UP)
     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-    alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
+    alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
 
   removeFile testStoreLogFile
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
 
-testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
-testServerConnectionAfterError t _ = do
-  withAgent1 $ \bob -> do
-    withAgent2 $ \alice -> do
-      withServer $ do
-        connect (bob, "bob") (alice, "alice")
-
-      bob <# ("", "", DOWN server ["alice"])
-      alice <# ("", "", DOWN server ["bob"])
-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
-      alice #:# "nothing else delivered before the server is restarted"
-      bob #:# "nothing else delivered before the server is restarted"
-
-  withAgent1 $ \bob -> do
-    withAgent2 $ \alice -> do
-      bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
-      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
-      withServer $ do
-        alice <# ("", "bob", SENT 5)
-        bob <# ("", "", UP server ["alice"])
-        bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-        bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
-        alice <# ("", "", UP server ["bob"])
-        alice #: ("1", "bob", "SEND 11\nhello again") #> ("1", "bob", MID 6)
-        alice <# ("", "bob", SENT 6)
-        bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
-
-  removeFile testStoreLogFile
-  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 -> 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 ()
 testMsgDeliveryAgentRestart t bob = do
-  let server = SMPServer "localhost" testPort2 testKeyHash
   withAgent $ \alice -> do
     withServer $ do
       connect (bob, "bob") (alice, "alice")
-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
-      alice <# ("", "bob", SENT 5)
+      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 4)
+      alice <# ("", "bob", SENT 4)
       bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-      bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
+      bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
       bob #:# "nothing else delivered before the server is down"
 
-    bob <# ("", "", DOWN server ["alice"])
-    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 6)
+    bob <# ("", "alice", DOWN)
+    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 5)
     alice #:# "nothing else delivered before the server is restarted"
     bob #:# "nothing else delivered before the server is restarted"
 
@@ -366,14 +324,14 @@ testMsgDeliveryAgentRestart t bob = do
       alice <#= \case
         (corrId, "bob", cmd) ->
           (corrId == "3" && cmd == OK)
-            || (corrId == "" && cmd == SENT 6)
+            || (corrId == "" && cmd == SENT 5)
         _ -> False
-      bob <# ("", "", UP server ["alice"])
+      bob <# ("", "alice", UP)
       bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
-      bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
+      bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
-  removeFile testDB
+  -- removeFile testDB
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort
@@ -398,11 +356,11 @@ testConcurrentMsgDelivery _ alice bob = do
   -- alice <# ("", "bob", SENT 1)
   -- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
   -- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
-  bob <# ("", "alice", SENT 6)
+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 5)
+  bob <# ("", "alice", SENT 5)
   -- if delivery is blocked it won't go further
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
+  alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
 
 testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
 testMsgDeliveryQuotaExceeded _ alice bob = do
@@ -415,9 +373,9 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
     alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
   (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
 
-  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 5)
+  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 4)
   -- if delivery is blocked it won't go further
-  alice <# ("", "bob2", SENT 5)
+  alice <# ("", "bob2", SENT 4)
 
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
@@ -466,6 +424,7 @@ syntaxTests t = do
       -- TODO: add tests with defined connection id
       it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
 
+  -- focus this test to test postgres
   describe "JOIN" $ do
     describe "valid" $ do
       it "using same server as in invitation" $

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 (..), smpClientVRange)
+import Simplex.Messaging.Protocol (smpClientVRange)
 import Simplex.Messaging.Version
 import Test.Hspec
 
@@ -20,7 +20,7 @@ uri = "smp.simplex.im"
 
 srv :: SMPServer
 srv =
-  ProtocolServer
+  SMPServer
     { host = "smp.simplex.im",
       port = "5223",
       keyHash = C.KeyHash "\215m\248\251"

tests/AgentTests/FunctionalAPITests.hs

@@ -1,28 +1,24 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests (functionalAPITests) where
 
-import Control.Concurrent (threadDelay)
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Unlift
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPAgentClient
-import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
+import SMPClient (withSmpServer)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
+import Simplex.Messaging.Agent.Env.Postgres (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
-import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ATransport (..))
+import System.Timeout
 import Test.Hspec
-import UnliftIO
+import UnliftIO.STM
 
 (##>) :: MonadIO m => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
 a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
@@ -48,20 +44,13 @@ functionalAPITests t = do
       withSmpServer t testAsyncJoiningOfflineBeforeActivation
     it "should connect with both clients going offline" $
       withSmpServer t testAsyncBothOffline
-    it "should connect on the second attempt if server was offline" $
-      testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
-  describe "Inactive client disconnection" $ do
-    it "should disconnect clients if it was inactive longer than TTL" $
-      testInactiveClientDisconnected t
-    it "should NOT disconnect active clients" $
-      testActiveClientNotDisconnected t
 
 testAgentClient :: IO ()
 testAgentClient = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  alice <- getSMPAgentClient cfg
+  bob <- getSMPAgentClient cfg {dbConnInfo = testDB2}
   Right () <- runExceptT $ do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
@@ -70,26 +59,26 @@ testAgentClient = do
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
-    -- message IDs 1 to 4 get assigned to control messages, so first MSG is assigned ID 5
-    5 <- sendMessage alice bobId "hello"
+    -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
+    4 <- sendMessage alice bobId "hello"
+    get alice ##> ("", bobId, SENT 4)
+    5 <- sendMessage alice bobId "how are you?"
     get alice ##> ("", bobId, SENT 5)
-    6 <- sendMessage alice bobId "how are you?"
-    get alice ##> ("", bobId, SENT 6)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 5
+    ackMessage bob aliceId 4
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 6
-    7 <- sendMessage bob aliceId "hello too"
+    ackMessage bob aliceId 5
+    6 <- sendMessage bob aliceId "hello too"
+    get bob ##> ("", aliceId, SENT 6)
+    7 <- sendMessage bob aliceId "message 1"
     get bob ##> ("", aliceId, SENT 7)
-    8 <- sendMessage bob aliceId "message 1"
-    get bob ##> ("", aliceId, SENT 8)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId 7
+    ackMessage alice bobId 6
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId 8
+    ackMessage alice bobId 7
     suspendConnection alice bobId
-    9 <- sendMessage bob aliceId "message 2"
-    get bob ##> ("", aliceId, MERR 9 (SMP AUTH))
+    8 <- sendMessage bob aliceId "message 2"
+    get bob ##> ("", aliceId, MERR 8 (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
   pure ()
@@ -104,13 +93,13 @@ testAgentClient = do
 
 testAsyncInitiatingOffline :: IO ()
 testAsyncInitiatingOffline = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  alice <- getSMPAgentClient cfg
+  bob <- getSMPAgentClient cfg {dbConnInfo = testDB2}
   Right () <- runExceptT $ do
     (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
     aliceId <- joinConnection bob cReq "bob's connInfo"
-    alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+    alice' <- liftIO $ getSMPAgentClient cfg
     subscribeConnection alice' bobId
     ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
@@ -122,15 +111,15 @@ testAsyncInitiatingOffline = do
 
 testAsyncJoiningOfflineBeforeActivation :: IO ()
 testAsyncJoiningOfflineBeforeActivation = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  alice <- getSMPAgentClient cfg
+  bob <- getSMPAgentClient cfg {dbConnInfo = testDB2}
   Right () <- runExceptT $ do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
     disconnectAgentClient bob
     ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient cfg {dbConnInfo = testDB2}
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -140,18 +129,18 @@ testAsyncJoiningOfflineBeforeActivation = do
 
 testAsyncBothOffline :: IO ()
 testAsyncBothOffline = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  alice <- getSMPAgentClient cfg
+  bob <- getSMPAgentClient cfg {dbConnInfo = testDB2}
   Right () <- runExceptT $ do
     (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
     aliceId <- joinConnection bob cReq "bob's connInfo"
     disconnectAgentClient bob
-    alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+    alice' <- liftIO $ getSMPAgentClient cfg
     subscribeConnection alice' bobId
     ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient cfg {dbConnInfo = testDB2}
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -159,37 +148,10 @@ testAsyncBothOffline = do
     exchangeGreetings alice' bobId bob' aliceId
   pure ()
 
-testAsyncServerOffline :: ATransport -> IO ()
-testAsyncServerOffline t = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  -- create connection and shutdown the server
-  Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
-    runExceptT $ createConnection alice SCMInvitation
-  -- connection fails
-  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
-  Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
-    ("", "", UP srv1 conns1) <- get alice
-    liftIO $ do
-      srv1 `shouldBe` testSMPServer
-      conns1 `shouldBe` [bobId]
-    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
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
+  alice <- getSMPAgentClient cfg
+  bob <- getSMPAgentClient cfg {dbConnInfo = testDB2, helloTimeout = 1}
   Right () <- runExceptT $ do
     (_, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
@@ -197,51 +159,13 @@ testAsyncHelloTimeout = do
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
   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
-    Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice SCMInvitation
-      get alice ##> ("", "", DOWN testSMPServer [connId])
-    pure ()
-
-testActiveClientNotDisconnected :: ATransport -> IO ()
-testActiveClientNotDisconnected t = do
-  let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
-  withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient agentCfg initAgentServers
-    ts <- getSystemTime
-    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
-      if milliseconds ts' - milliseconds ts < 2200
-        then do
-          -- keep sending SUB for 2.2 seconds
-          liftIO $ threadDelay 200000
-          subscribeConnection alice connId
-          keepSubscribing alice connId ts
-        else do
-          -- check that nothing is sent from agent
-          Nothing <- 800000 `timeout` get alice
-          liftIO $ threadDelay 1200000
-          -- and after 2 sec of inactivity DOWN is sent
-          get alice ##> ("", "", DOWN testSMPServer [connId])
-    milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
-
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings alice bobId bob aliceId = do
-  5 <- sendMessage alice bobId "hello"
-  get alice ##> ("", bobId, SENT 5)
+  4 <- sendMessage alice bobId "hello"
+  get alice ##> ("", bobId, SENT 4)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId 5
-  6 <- sendMessage bob aliceId "hello too"
-  get bob ##> ("", aliceId, SENT 6)
+  ackMessage bob aliceId 4
+  5 <- sendMessage bob aliceId "hello too"
+  get bob ##> ("", aliceId, SENT 5)
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId 6
+  ackMessage alice bobId 5

tests/AgentTests/NotificationTests.hs

@@ -1,167 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module AgentTests.NotificationTests where
-
--- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-
-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)
-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 Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
-import Simplex.Messaging.Agent.Protocol
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Protocol (ErrorType (AUTH))
-import Simplex.Messaging.Transport (ATransport)
-import Simplex.Messaging.Util (tryE)
-import System.Directory (removeFile)
-import Test.Hspec
-import UnliftIO.STM
-
-notificationTests :: ATransport -> Spec
-notificationTests t =
-  after_ (removeFile testDB) $
-    describe "Managing notification tokens" $ do
-      it "should register and verify notification token" $
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationToken apns
-      it "should allow repeated registration with the same credentials" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNtfTokenRepeatRegistration apns
-      it "should allow the second registration with different credentials and delete the first after verification" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNtfTokenSecondRegistration apns
-      it "should re-register token when notification server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenServerRestart t apns
-
-testNotificationToken :: APNSMockServer -> IO ()
-testNotificationToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient agentCfg 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 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
-  J.Object o <- pure v
-  liftEither . bimap INTERNAL (U.decodeLenient . encodeUtf8) $ JT.parseEither (J..: key) o
-
--- logCfg :: LogConfig
--- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
-
-testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
-testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
-  -- setLogLevel LogError -- LogDebug
-  -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient agentCfg 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
-    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 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 {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 verification nonce
-
-    NTRegistered <- registerNtfToken a' tkn
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-      atomically $ readTBQueue apnsQ
-    verification' <- ntfData' .-> "verification"
-    nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
-    liftIO $ sendApnsResponse' APNSRespOk
-
-    -- at this point the first token is still active
-    NTActive <- checkNtfToken a tkn
-    -- and the second is not yet verified
-    NTConfirmed <- checkNtfToken a' tkn
-    -- now the second token registration is verified
-    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 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
-    pure ntfData
-  -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
-  threadDelay 1000000
-  disconnectAgentClient a
-  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
-  Right () <- withNtfServer t . runExceptT $ do
-    verification <- ntfData .-> "verification"
-    nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    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 verification' nonce'
-    NTActive <- checkNtfToken a' tkn
-    enableNtfCron a' tkn 30
-  pure ()

tests/AgentTests/PostgresTests.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module AgentTests.PostgresTests (postgresStoreTests) 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
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time
+import Data.Word (Word32)
+import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
+import qualified Database.PostgreSQL.Simple as DB
+import SMPClient (testKeyHash)
+import Simplex.Messaging.Agent.Client ()
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.Postgres
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import qualified Simplex.Messaging.Crypto as C
+import System.Random
+import Test.Hspec
+import UnliftIO.Directory (removeFile)
+
+withStore :: SpecWith PostgresStore -> Spec
+withStore = before createStore
+
+createStore :: IO PostgresStore
+createStore = do
+  let dbConnInfo = defaultConnectInfo {connectDatabase = "agent_poc_1"}
+  createPostgresStore dbConnInfo 1 Migrations.app
+
+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
+postgresStoreTests :: Spec
+postgresStoreTests = do
+  -- withStore2 $ do
+  --   describe "stress test" testConcurrentWrites
+  withStore $ do
+    -- describe "store setup" $ do
+    --   testCompiledThreadsafe
+    --   testForeignKeysEnabled
+    describe "store methods" $ do
+      describe "Queue and Connection management" $ do
+        -- describe "createRcvConn" $ do
+        --   testCreateRcvConn
+        --   testCreateRcvConnRandomId
+        --   testCreateRcvConnDuplicate
+        fdescribe "createSndConn" $ do
+          testCreateSndConn
+
+--     testCreateSndConnRandomID
+--     testCreateSndConnDuplicate
+--   describe "getRcvConn" testGetRcvConn
+--   describe "deleteConn" $ do
+--     testDeleteRcvConn
+--     testDeleteSndConn
+--     testDeleteDuplexConn
+--   describe "upgradeRcvConnToDuplex" $ do
+--     testUpgradeRcvConnToDuplex
+--   describe "upgradeSndConnToDuplex" $ do
+--     testUpgradeSndConnToDuplex
+--   describe "set Queue status" $ do
+--     describe "setRcvQueueStatus" $ do
+--       testSetRcvQueueStatus
+--     describe "setSndQueueStatus" $ do
+--       testSetSndQueueStatus
+--     testSetQueueStatusDuplex
+-- describe "Msg management" $ do
+--   describe "create Msg" $ do
+--     testCreateRcvMsg
+--     testCreateSndMsg
+--     testCreateRcvAndSndMsgs
+
+cData1 :: ConnData
+cData1 = ConnData {connId = "conn1"}
+
+testPrivateSignKey :: C.APrivateSignKey
+testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+
+testPrivDhKey :: C.PrivateKeyX25519
+testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"
+
+testDhSecret :: C.DhSecretX25519
+testDhSecret = "01234567890123456789012345678901"
+
+rcvQueue1 :: RcvQueue
+rcvQueue1 =
+  RcvQueue
+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+      rcvId = "1234",
+      rcvPrivateKey = testPrivateSignKey,
+      rcvDhSecret = testDhSecret,
+      e2ePrivKey = testPrivDhKey,
+      e2eDhSecret = Nothing,
+      sndId = Just "2345",
+      status = New
+    }
+
+sndQueue1 :: SndQueue
+sndQueue1 =
+  SndQueue
+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+      sndId = "3456",
+      sndPrivateKey = testPrivateSignKey,
+      e2eDhSecret = testDhSecret,
+      status = New
+    }
+
+testCreateSndConn :: SpecWith PostgresStore
+testCreateSndConn =
+  it "should create SndConnection and add RcvQueue" $ \store -> do
+    g <- newTVarIO =<< drgNew
+    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)

tests/AgentTests/SQLiteTests.hs

@@ -51,7 +51,7 @@ 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) 4 Migrations.app True
+  createSQLiteStore (testDB <> show r) 4 Migrations.app
 
 removeStore :: SQLiteStore -> IO ()
 removeStore store = do
@@ -173,9 +173,7 @@ sndQueue1 =
   SndQueue
     { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       sndId = "3456",
-      sndPublicKey = Nothing,
       sndPrivateKey = testPrivateSignKey,
-      e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New
     }
@@ -305,9 +303,7 @@ testUpgradeRcvConnToDuplex =
           SndQueue
             { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = "2345",
-              sndPublicKey = Nothing,
               sndPrivateKey = testPrivateSignKey,
-              e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New
             }
@@ -397,7 +393,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
             sndMsgId = externalSndId,
             broker = (brokerId, ts)
           },
-      msgType = AM_A_MSG_,
+      msgType = A_MSG_,
       msgBody = hw,
       internalHash,
       externalPrevSndHash = "hash_from_sender"
@@ -426,7 +422,7 @@ mkSndMsgData internalId internalSndId internalHash =
     { internalId,
       internalSndId,
       internalTs = ts,
-      msgType = AM_A_MSG_,
+      msgType = A_MSG_,
       msgBody = hw,
       internalHash,
       prevMsgHash = internalHash

tests/AgentTests/SchemaDump.hs

@@ -1,29 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module AgentTests.SchemaDump where
-
-import Control.Monad (void)
-import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
-import System.Process (readCreateProcess, shell)
-import Test.Hspec
-
-testDB :: FilePath
-testDB = "tests/tmp/test_agent_schema.db"
-
-schema :: FilePath
-schema = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql"
-
-schemaDumpTest :: Spec
-schemaDumpTest =
-  it "verify and overwrite schema dump" testVerifySchemaDump
-
-testVerifySchemaDump :: IO ()
-testVerifySchemaDump = do
-  void $ createSQLiteStore testDB 1 Migrations.app False
-  void $ readCreateProcess (shell $ "touch " <> schema) ""
-  savedSchema <- readFile schema
-  savedSchema `seq` pure ()
-  void $ readCreateProcess (shell $ "sqlite3 " <> testDB <> " '.schema --indent' > " <> schema) ""
-  currentSchema <- readFile schema
-  savedSchema `shouldBe` currentSchema

tests/NtfClient.hs

@@ -1,194 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-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 Data.ByteString.Builder (lazyByteString)
-import Data.ByteString.Char8 (ByteString)
-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.Agent (defaultSMPClientAgentConfig)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
-import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Transport
-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 UnliftIO.Async
-import UnliftIO.Concurrent
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-import UnliftIO.Timeout (timeout)
-
-testHost :: HostName
-testHost = "localhost"
-
-ntfTestPort :: ServiceName
-ntfTestPort = "6001"
-
-apnsTestPort :: ServiceName
-apnsTestPort = "6010"
-
-testKeyHash :: C.KeyHash
-testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
-
-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) >>= \case
-      Right th -> client th
-      Left e -> error $ show e
-
-ntfServerCfg :: NtfServerConfig
-ntfServerCfg =
-  NtfServerConfig
-    { transports = undefined,
-      subIdBytes = 24,
-      regCodeBytes = 32,
-      clientQSize = 1,
-      subQSize = 1,
-      pushQSize = 1,
-      smpAgentCfg = defaultSMPClientAgentConfig,
-      apnsConfig =
-        defaultAPNSPushClientConfig
-          { apnsHost = "localhost",
-            apnsPort = apnsTestPort,
-            http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
-          },
-      inactiveClientExpiration = Just defaultInactiveClientExpiration,
-      -- CA certificate private key is not needed for initialization
-      caCertificateFile = "tests/fixtures/ca.crt",
-      privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
-    }
-
-withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withNtfServerThreadOn t port' =
-  serverBracket
-    (\started -> runNtfServerBlocking started ntfServerCfg {transports = [(port', t)]})
-    (pure ())
-
-serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
-serverBracket process afterProcess f = do
-  started <- newEmptyTMVarIO
-  E.bracket
-    (forkIOWithUnmask ($ process started))
-    (\t -> killThread t >> afterProcess >> waitFor started "stop")
-    (\t -> waitFor started "start" >> f t)
-  where
-    waitFor started s =
-      5_000_000 `timeout` atomically (takeTMVar started) >>= \case
-        Nothing -> error $ "server did not " <> s
-        _ -> pure ()
-
-withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
-withNtfServerOn t port' = withNtfServerThreadOn t port' . const
-
-withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
-withNtfServer t = withNtfServerOn t ntfTestPort
-
-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 ::
-  forall c smp.
-  (Transport c, Encoding smp) =>
-  TProxy c ->
-  (Maybe C.ASignature, ByteString, ByteString, smp) ->
-  IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
-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')
-      pure ()
-    tGet' h = do
-      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
-      pure (Nothing, corrId, qId, cmd)
-
-data APNSMockRequest = APNSMockRequest
-  { notification :: APNSNotification,
-    sendApnsResponse :: APNSMockResponse -> IO ()
-  }
-
-data APNSMockResponse = APNSRespOk | APNSRespError Status Text
-
-data APNSMockServer = APNSMockServer
-  { action :: Async (),
-    apnsQ :: TBQueue APNSMockRequest,
-    http2Server :: HTTP2Server
-  }
-
-apnsMockServerConfig :: HTTP2ServerConfig
-apnsMockServerConfig =
-  HTTP2ServerConfig
-    { qSize = 1,
-      http2Port = apnsTestPort,
-      serverSupported = http2TLSParams,
-      caCertificateFile = "tests/fixtures/ca.crt",
-      privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
-    }
-
-withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
-withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
-
-deriving instance Generic APNSAlertBody
-
-deriving instance FromJSON APNSAlertBody
-
-instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions
-
-deriving instance FromJSON APNSNotification
-
-deriving instance ToJSON APNSErrorResponse
-
-getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
-getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
-  http2Server <- getHTTP2Server config
-  apnsQ <- newTBQueueIO qSize
-  action <- async $ runAPNSMockServer apnsQ http2Server
-  pure APNSMockServer {action, apnsQ, http2Server}
-  where
-    runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do
-      HTTP2Request {reqBody, sendResponse} <- atomically $ readTBQueue reqQ
-      let sendApnsResponse = \case
-            APNSRespOk -> sendResponse $ H.responseNoBody N.ok200 []
-            APNSRespError status reason ->
-              sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason}
-      case J.decodeStrict' reqBody of
-        Just notification -> atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
-        _ -> sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
-
-closeAPNSMockServer :: APNSMockServer -> IO ()
-closeAPNSMockServer APNSMockServer {action, http2Server} = do
-  closeHTTP2Server http2Server
-  uninterruptibleCancel action

tests/NtfServerTests.hs

@@ -1,36 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module NtfServerTests where
-
-import Data.ByteString.Char8 (ByteString)
-import NtfClient
-import ServerTests (sampleDhPubKey, samplePubKey, sampleSig)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Transport
-import Test.Hspec
-
-ntfServerTests :: ATransport -> Spec
-ntfServerTests t = do
-  describe "notifications server protocol syntax" $ ntfSyntaxTests t
-
-ntfSyntaxTests :: ATransport -> Spec
-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', "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 =>
-      (Maybe C.ASignature, ByteString, ByteString, smp) ->
-      (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
-      Expectation
-    command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response

tests/SMPAgentClient.hs

@@ -10,8 +10,8 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import qualified Data.ByteString.Char8 as B
 import qualified Data.List.NonEmpty as L
+import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
 import Network.Socket (HostName, ServiceName)
-import NtfClient (ntfTestPort)
 import SMPClient
   ( serverBracket,
     testKeyHash,
@@ -21,14 +21,13 @@ import SMPClient
     withSmpServerOn,
     withSmpServerThreadOn,
   )
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
+import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
@@ -45,14 +44,23 @@ agentTestPort2 = "5011"
 agentTestPort3 :: ServiceName
 agentTestPort3 = "5012"
 
-testDB :: String
-testDB = "tests/tmp/smp-agent.test.protocol.db"
+-- testDB :: String
+-- testDB = "tests/tmp/smp-agent.test.protocol.db"
 
-testDB2 :: String
-testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
+testDB :: ConnectInfo
+testDB = defaultConnectInfo {connectDatabase = "agent_poc_1"}
 
-testDB3 :: String
-testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
+-- testDB2 :: String
+-- testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
+
+testDB2 :: ConnectInfo
+testDB2 = defaultConnectInfo {connectDatabase = "agent_poc_2"}
+
+-- testDB3 :: String
+-- testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
+
+testDB3 :: ConnectInfo
+testDB3 = defaultConnectInfo {connectDatabase = "agent_poc_3"}
 
 smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
 smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> tGetRaw h
@@ -73,10 +81,10 @@ runSmpAgentServerTest test =
 smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
 smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
 
-runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
+runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, ConnectInfo)] -> ([c] -> m a) -> m a
 runSmpAgentTestN agents test = withSmpServer t $ run agents []
   where
-    run :: [(ServiceName, ServiceName, String)] -> [c] -> m a
+    run :: [(ServiceName, ServiceName, ConnectInfo)] -> [c] -> m a
     run [] hs = test hs
     run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
     t = transport @c
@@ -89,7 +97,7 @@ runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClien
     run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
     t = transport @c
 
-smpAgentTestN :: Transport c => [(ServiceName, ServiceName, String)] -> ([c] -> IO ()) -> Expectation
+smpAgentTestN :: Transport c => [(ServiceName, ServiceName, ConnectInfo)] -> ([c] -> IO ()) -> Expectation
 smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
 
 smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
@@ -155,51 +163,36 @@ smpAgentTest1_1_1 test' =
     _test [h] = test' h
     _test _ = error "expected 1 handle"
 
-testSMPServer :: SMPServer
-testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
-
-initAgentServers :: InitialAgentServers
-initAgentServers =
-  InitialAgentServers
-    { smp = L.fromList [testSMPServer],
-      ntf = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
-    }
-
-agentCfg :: AgentConfig
-agentCfg =
+cfg :: AgentConfig
+cfg =
   defaultAgentConfig
     { tcpPort = agentTestPort,
+      smpServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
       tbqSize = 1,
-      dbFile = testDB,
+      dbConnInfo = testDB,
       smpCfg =
-        defaultClientConfig
+        smpDefaultConfig
           { qSize = 1,
             defaultTransport = (testPort, transport @TLS),
             tcpTimeout = 500_000
           },
-      ntfCfg =
-        defaultClientConfig
-          { qSize = 1,
-            defaultTransport = (ntfTestPort, transport @TLS)
-          },
-      reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
+      reconnectInterval = (reconnectInterval defaultAgentConfig) {initialInterval = 50_000},
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"
     }
 
-withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, ConnectInfo) -> m () -> (ThreadId -> m a) -> m a
 withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
-  let cfg' = agentCfg {tcpPort = port', dbFile = db'}
-      initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
+  let cfg' = cfg {tcpPort = port', dbConnInfo = db', smpServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
    in serverBracket
-        (\started -> runSMPAgentBlocking t started cfg' initServers')
+        (\started -> runSMPAgentBlocking t started cfg')
         afterProcess
 
-withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile db'
+withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, ConnectInfo) -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ pure () -- $ removeFile db'
 
-withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m a -> m a
+withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, ConnectInfo) -> m a -> m a
 withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
 
 withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
@@ -207,7 +200,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
 testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  runTransportClient agentTestHost port' testKeyHash $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h

tests/SMPClient.hs

@@ -19,9 +19,9 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
@@ -43,13 +43,10 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 testStoreLogFile :: FilePath
 testStoreLogFile = "tests/tmp/smp-server-store.log"
 
-testStoreMsgsFile :: FilePath
-testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
-
 testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testSMPClient client =
-  runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
-    liftIO (runExceptT $ smpClientHandshake h testKeyHash) >>= \case
+  runTransportClient testHost testPort testKeyHash $ \h ->
+    liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -62,32 +59,25 @@ cfg =
       msgQueueQuota = 4,
       queueIdBytes = 24,
       msgIdBytes = 24,
-      storeLogFile = Nothing,
-      storeMsgsFile = Nothing,
-      allowNewQueues = True,
-      messageExpiration = Just defaultMessageExpiration,
-      inactiveClientExpiration = Just defaultInactiveClientExpiration,
-      logStatsInterval = Nothing,
-      logStatsStartTime = 0,
+      storeLog = Nothing,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"
     }
 
-withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
-
 withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile}
-
-withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerConfigOn t cfg' port' =
+withSmpServerStoreLogOn t port' client = do
+  s <- liftIO $ openReadStoreLog testStoreLogFile
   serverBracket
-    (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
+    (\started -> runSMPServerBlocking started cfg {transports = [(port', t)], storeLog = Just s})
     (pure ())
+    client
 
 withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerThreadOn t = withSmpServerConfigOn t cfg
+withSmpServerThreadOn t port' =
+  serverBracket
+    (\started -> runSMPServerBlocking started cfg {transports = [(port', t)]})
+    (pure ())
 
 serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
 serverBracket process afterProcess f = do

tests/ServerTests.hs

@@ -9,7 +9,7 @@
 
 module ServerTests where
 
-import Control.Concurrent (ThreadId, killThread, threadDelay)
+import Control.Concurrent (ThreadId, killThread)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, try)
 import Control.Monad.Except (forM, forM_, runExceptT)
@@ -21,8 +21,6 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
-import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport
 import System.Directory (removeFile)
 import System.TimeIt (timeItT)
@@ -31,24 +29,18 @@ import Test.HUnit
 import Test.Hspec
 
 serverTests :: ATransport -> Spec
-serverTests t@(ATransport t') = do
+serverTests t = do
   describe "SMP syntax" $ syntaxTests t
   describe "SMP queues" $ do
     describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
     describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
     describe "Stress test" $ stressTest t
-    describe "allowNewQueues setting" $ testAllowNewQueues t'
   describe "SMP messages" $ do
     describe "duplex communication over 2 SMP connections" $ testDuplex t
     describe "switch subscription to another TCP connection" $ testSwitchSub t
   describe "Store log" $ testWithStoreLog t
-  describe "Restore messages" $ testRestoreMessages t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
-  describe "Message expiration" $ do
-    testMsgExpireOnSend t'
-    testMsgExpireOnInterval t'
-    testMsgNOTExpireOnInterval t'
 
 pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg
 pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
@@ -212,16 +204,6 @@ stressTest (ATransport t) =
       closeConnection $ connection h2
       subscribeQueues h3
 
-testAllowNewQueues :: forall c. Transport c => TProxy c -> Spec
-testAllowNewQueues t =
-  it "should prohibit creating new queues with allowNewQueues = False" $ do
-    withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ ->
-      testSMPClient @c $ \h -> do
-        (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-        (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
-        Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
-        pure ()
-
 testDuplex :: ATransport -> Spec
 testDuplex (ATransport t) =
   it "should create 2 simplex connections and exchange messages" $
@@ -353,7 +335,7 @@ testWithStoreLog at@(ATransport t) =
       Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
       pure ()
 
-    logSize testStoreLogFile `shouldReturn` 6
+    logSize `shouldReturn` 6
 
     withSmpServerThreadOn at testPort . runTest t $ \h -> do
       sId1 <- readTVarIO senderId1
@@ -378,7 +360,7 @@ testWithStoreLog at@(ATransport t) =
       Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too")
       pure ()
 
-    logSize testStoreLogFile `shouldReturn` 1
+    logSize `shouldReturn` 1
     removeFile testStoreLogFile
   where
     runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
@@ -389,79 +371,11 @@ testWithStoreLog at@(ATransport t) =
     runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
-logSize :: FilePath -> IO Int
-logSize f =
-  try (length . B.lines <$> B.readFile f) >>= \case
-    Right l -> pure l
-    Left (_ :: SomeException) -> logSize f
-
-testRestoreMessages :: ATransport -> Spec
-testRestoreMessages at@(ATransport t) =
-  it "should store messages on exit and restore on start" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    recipientId <- newTVarIO ""
-    recipientKey <- newTVarIO Nothing
-    dhShared <- newTVarIO Nothing
-    senderId <- newTVarIO ""
-
-    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
-      runClient t $ \h1 -> do
-        (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
-        atomically $ do
-          writeTVar recipientId rId
-          writeTVar recipientKey $ Just rKey
-          writeTVar dhShared $ Just dh
-          writeTVar senderId sId
-        Resp "1" _ OK <- signSendRecv h sKey ("1", sId, SEND "hello")
-        Resp "" _ (MSG mId1 _ msg1) <- tGet h1
-        Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK)
-        (C.cbDecrypt dh (C.cbNonce mId1) msg1, Right "hello") #== "message delivered"
-      -- messages below are delivered after server restart
-      sId <- readTVarIO senderId
-      Resp "2" _ OK <- signSendRecv h sKey ("2", sId, SEND "hello 2")
-      Resp "3" _ OK <- signSendRecv h sKey ("3", sId, SEND "hello 3")
-      Resp "4" _ OK <- signSendRecv h sKey ("4", sId, SEND "hello 4")
-      pure ()
-
-    logSize testStoreLogFile `shouldReturn` 2
-    logSize testStoreMsgsFile `shouldReturn` 3
-
-    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
-      rId <- readTVarIO recipientId
-      Just rKey <- readTVarIO recipientKey
-      Just dh <- readTVarIO dhShared
-      Resp "2" _ (MSG mId2 _ msg2) <- signSendRecv h rKey ("2", rId, SUB)
-      (C.cbDecrypt dh (C.cbNonce mId2) msg2, Right "hello 2") #== "restored message delivered"
-      Resp "3" _ (MSG mId3 _ msg3) <- signSendRecv h rKey ("3", rId, ACK)
-      (C.cbDecrypt dh (C.cbNonce mId3) msg3, Right "hello 3") #== "restored message delivered"
-      Resp "4" _ (MSG mId4 _ msg4) <- signSendRecv h rKey ("4", rId, ACK)
-      (C.cbDecrypt dh (C.cbNonce mId4) msg4, Right "hello 4") #== "restored message delivered"
-
-    logSize testStoreLogFile `shouldReturn` 1
-    -- the last message is not removed because it was not ACK'd
-    logSize testStoreMsgsFile `shouldReturn` 1
-
-    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
-      rId <- readTVarIO recipientId
-      Just rKey <- readTVarIO recipientKey
-      Just dh <- readTVarIO dhShared
-      Resp "4" _ (MSG mId4 _ msg4) <- signSendRecv h rKey ("4", rId, SUB)
-      Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK)
-      (C.cbDecrypt dh (C.cbNonce mId4) msg4, Right "hello 4") #== "restored message delivered"
-
-    logSize testStoreLogFile `shouldReturn` 1
-    logSize testStoreMsgsFile `shouldReturn` 0
-
-    removeFile testStoreLogFile
-    removeFile testStoreMsgsFile
-  where
-    runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
-    runTest _ test' server = do
-      testSMPClient test' `shouldReturn` ()
-      killThread server
-
-    runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
-    runClient _ test' = testSMPClient test' `shouldReturn` ()
+    logSize :: IO Int
+    logSize =
+      try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case
+        Right l -> pure l
+        Left (_ :: SomeException) -> logSize
 
 createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
 createAndSecureQueue h sPub = do
@@ -552,59 +466,6 @@ testMessageNotifications (ATransport t) =
         Nothing -> return ()
         Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
 
-testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec
-testMsgExpireOnSend t =
-  it "should expire messages that are not received before messageTTL on SEND" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
-    withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
-      testSMPClient @c $ \sh -> do
-        (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should expire)")
-        threadDelay 2500000
-        Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, SEND "hello (should NOT expire)")
-        testSMPClient @c $ \rh -> do
-          Resp "3" _ (MSG mId _ msg) <- signSendRecv rh rKey ("3", rId, SUB)
-          (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
-            Nothing -> return ()
-            Just _ -> error "nothing else should be delivered"
-
-testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
-testMsgExpireOnInterval t =
-  it "should expire messages that are not received before messageTTL after expiry interval" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
-    withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
-      testSMPClient @c $ \sh -> do
-        (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should expire)")
-        threadDelay 2500000
-        testSMPClient @c $ \rh -> do
-          Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, SUB)
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
-            Nothing -> return ()
-            Just _ -> error "nothing should be delivered"
-
-testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
-testMsgNOTExpireOnInterval t =
-  it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
-    withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
-      testSMPClient @c $ \sh -> do
-        (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should NOT expire)")
-        threadDelay 2500000
-        testSMPClient @c $ \rh -> do
-          Resp "2" _ (MSG mId _ msg) <- signSendRecv rh rKey ("2", rId, SUB)
-          (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
-            Nothing -> return ()
-            Just _ -> error "nothing else should be delivered"
-
 samplePubKey :: C.APublicVerifyKey
 samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="
 
@@ -635,7 +496,7 @@ syntaxTests (ATransport t) = do
   describe "SEND" $ do
     it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
     it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
-    it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
+    it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_QUEUE)
   describe "PING" $ do
     it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)
   describe "broker response not allowed" $ do

tests/Test.hs

@@ -1,23 +1,18 @@
 {-# LANGUAGE TypeApplications #-}
 
 import AgentTests (agentTests)
-import AgentTests.NotificationTests (notificationTests)
 import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.VersionRangeTests
-import NtfServerTests (ntfServerTests)
 import ServerTests
 import Simplex.Messaging.Transport (TLS, Transport (..))
 import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
-import System.Environment (setEnv)
 import Test.Hspec
 
 main :: IO ()
 main = do
   createDirectoryIfMissing False "tests/tmp"
-  setEnv "APNS_KEY_ID" "H82WD9K9AQ"
-  setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
   hspec $ do
     describe "Core tests" $ do
       describe "Encoding tests" encodingTests
@@ -25,8 +20,5 @@ main = do
       describe "Version range" versionRangeTests
     describe "SMP server via TLS" $ serverTests (transport @TLS)
     describe "SMP server via WebSockets" $ serverTests (transport @WS)
-    describe "Notifications server" $ do
-      ntfServerTests (transport @TLS)
-      notificationTests (transport @TLS)
     describe "SMP client agent" $ agentTests (transport @TLS)
   removeDirectoryRecursive "tests/tmp"

tests/fixtures/AuthKey_H82WD9K9AQ.p8

@@ -1,6 +0,0 @@
------BEGIN PRIVATE KEY-----
-MIGTAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBHkwdwIBAQQgWuPap5jF6eioxuHM
-XWZWUK78LdcxkTnMXWg2GqyXuBugCgYIKoZIzj0DAQehRANCAAQn64CvAIbEEzvM
-KwYjlOxVD5SxlgP1ZcYvVM/+VHLFu0aCkG7ueICTi3qWyqoB5hjjuAqwtc3EK0q0
-yupyM7Yx
------END PRIVATE KEY-----