6.1.1.0

* smp server: stop server faster

* .702

* asks

* fix leak

* kill client when server stopped

* remove version

* fix version

.github/workflows/build.yml

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

CHANGELOG.md

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

README.md

@@ -149,8 +149,15 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
 You can install and setup servers automatically using our script:
 
 ```sh
-curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
-&& if echo 'c90886104cd640b2ed64921dba80e90691db36788e8d6dcc13d8f33f92f0ea54 simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
+curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh &&\
+if echo '53fcdb4ceab324316e2c4cda7e84dbbb344f32550a65975a7895425e5a1be757 simplex-server-install.sh' | sha256sum -c; then
+  chmod +x ./simplex-server-install.sh
+  ./simplex-server-install.sh
+  rm ./simplex-server-install.sh
+else
+  echo "SHA-256 checksum is incorrect!"
+  rm ./simplex-server-install.sh
+fi
 ```
 
 ### Build from source

apps/smp-server/static/index.html

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

apps/smp-server/web/Static.hs

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

install.sh

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

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 6.1.0.4
+version: 6.1.1.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,

protocol/xftp.md

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

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

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

scripts/main/simplex-servers-update

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

scripts/main/smp-server.service

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

scripts/main/xftp-server.service

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

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        6.1.0.4
+version:        6.1.1.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -154,6 +154,7 @@ library
       Simplex.Messaging.Notifications.Client
       Simplex.Messaging.Notifications.Protocol
       Simplex.Messaging.Notifications.Server
+      Simplex.Messaging.Notifications.Server.Control
       Simplex.Messaging.Notifications.Server.Env
       Simplex.Messaging.Notifications.Server.Main
       Simplex.Messaging.Notifications.Server.Push.APNS
@@ -174,6 +175,7 @@ library
       Simplex.Messaging.Server.Main
       Simplex.Messaging.Server.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
+      Simplex.Messaging.Server.NtfStore
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.QueueInfo
       Simplex.Messaging.Server.QueueStore.STM
@@ -613,6 +615,7 @@ test-suite simplexmq-test
       CoreTests.EncodingTests
       CoreTests.RetryIntervalTests
       CoreTests.SOCKSSettings
+      CoreTests.StoreLogTests
       CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
       CoreTests.VersionRangeTests

src/Simplex/FileTransfer/Client.hs

@@ -104,7 +104,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = (transportClientConfig xftpNetworkConfig useHost True) {alpn = clientALPN}
+  let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -113,7 +113,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let HTTP2Client {sessionId, sessionALPN} = http2Client
       v = VersionXFTP 1
       thServerVRange = versionToRange v
-      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
     Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0

src/Simplex/FileTransfer/Server.hs

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

src/Simplex/FileTransfer/Server/Control.hs

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

src/Simplex/FileTransfer/Server/Env.hs

@@ -72,7 +72,7 @@ data XFTPServerConfig = XFTPServerConfig
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 43200, -- seconds, 12 hours
+    { ttl = 21600, -- seconds, 6 hours
       checkInterval = 3600 -- seconds, 1 hours
     }
 

src/Simplex/FileTransfer/Server/Main.hs

@@ -101,6 +101,7 @@ xftpServerCLI cfgPath logPath = do
                \\n\
                \# control_port_admin_password:\n\
                \# control_port_user_password:\n\
+               \\n\
                \[TRANSPORT]\n\
                \# host is only used to print server address on start\n"
             <> ("host: " <> T.pack host <> "\n")

src/Simplex/Messaging/Agent.hs

@@ -56,6 +56,7 @@ module Simplex.Messaging.Agent
     createConnection,
     changeConnectionUser,
     prepareConnectionToJoin,
+    prepareConnectionToAccept,
     joinConnection,
     allowConnection,
     acceptContact,
@@ -332,7 +333,7 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
 
 -- | Create SMP agent connection (NEW command)
 createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
-createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs
+createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs
 {-# INLINE createConnection #-}
 
 -- | Changes the user id associated with a connection
@@ -348,10 +349,13 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
 prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
 prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs
 
+-- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
+prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId
+prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs
+
 -- | Join SMP agent connection (JOIN command).
-joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
-joinConnection c userId Nothing enableNtfs = withAgentEnv c .:: joinConn c userId "" False enableNtfs
-joinConnection c userId (Just connId) enableNtfs = withAgentEnv c .:: joinConn c userId connId True enableNtfs
+joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
+joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs
 {-# INLINE joinConnection #-}
 
 -- | Allow connection to continue after CONF notification (LET command)
@@ -360,8 +364,8 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
 {-# INLINE allowConnection #-}
 
 -- | Accept contact after REQ notification (ACPT command)
-acceptContact :: AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
-acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs
+acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
+acceptContact c connId enableNtfs = withAgentEnv c .:: acceptContact' c connId enableNtfs
 {-# INLINE acceptContact #-}
 
 -- | Reject contact (RJCT command)
@@ -649,15 +653,15 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
 
 newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
 newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
-  connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys)
+  connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
   enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
   pure connId
 
-newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
-newConnNoQueues c userId connId enableNtfs cMode pqSupport = do
+newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
+newConnNoQueues c userId enableNtfs cMode pqSupport = do
   g <- asks random
   connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
-  let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
+  let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
   withStore c $ \db -> createNewConn db g cData cMode
 
 joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
@@ -744,9 +748,12 @@ switchConnectionAsync' c corrId connId =
             pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
 
-newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
-newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
-  getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode
+newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
+newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do
+  srv <- getSMPServer c userId
+  connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
+  cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
+  pure (connId, cReq)
 
 changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
 changeConnectionUser' c oldUserId connId newUserId = do
@@ -758,15 +765,7 @@ changeConnectionUser' c oldUserId connId newUserId = do
   where
     updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
 
-newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
-newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do
-  connId' <-
-    if hasNewConn
-      then pure connId
-      else newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
-  newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv
-
-newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
+newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
 newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
   case (cMode, pqInitKeys) of
     (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
@@ -782,12 +781,12 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
     atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
   let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
   case cMode of
-    SCMContact -> pure (connId, CRContactUri crData)
+    SCMContact -> pure $ CRContactUri crData
     SCMInvitation -> do
       g <- asks random
       (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
       withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
-      pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
+      pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
 
 newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
 newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
@@ -807,16 +806,24 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
           cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
       withStore c $ \db -> createNewConn db g cData SCMInvitation
 
-joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
-joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do
+newConnToAccept :: AgentClient -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId
+newConnToAccept c connId enableNtfs invId pqSup = do
+  Invitation {connReq, contactConnId} <- withStore c (`getInvitation` invId)
+  withStore c (`getConn` contactConnId) >>= \case
+    SomeConn _ (ContactConnection ConnData {userId} _) ->
+      newConnToJoin c userId connId enableNtfs connReq pqSup
+    _ -> throwE $ CMD PROHIBITED "newConnToAccept"
+
+joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
+joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
   srv <- case cReq of
     CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
       getNextServer c userId [qServer q]
     _ -> getSMPServer c userId
-  joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv
+  joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
 
-startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448)
-startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup =
+startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448)
+startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
   lift (compatibleInvitationUri cReqUri) >>= \case
     Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do
       g <- asks random
@@ -829,11 +836,14 @@ startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup =
           rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
       -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
       -- e2ePubKey is always present, it's Maybe historically
-      (q, e2ePubKey) <- case sq_ of
-        Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k)
-        _ -> lift $ newSndQueue userId "" qInfo
+      q <- case sq_ of
+        Just sq@SndQueue {e2ePubKey = Just _k} -> pure (sq :: SndQueue) {dbQueueId = DBNewQueue}
+        _ -> lift $ fst <$> newSndQueue userId "" qInfo
       let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
-      pure (cData, q, e2ePubKey, rc, e2eSndParams)
+      sq' <- withStore c $ \db -> runExceptT $ do
+        liftIO $ createRatchet db connId rc
+        maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
+      pure (cData, sq', e2eSndParams)
     Nothing -> throwE $ AGENT A_VERSION
 
 connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
@@ -866,34 +876,25 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
 versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
 {-# INLINE versionPQSupport_ #-}
 
-joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, SndQueueSecured)
-joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
+joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
+joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
   withInvLock c (strEncode inv) "joinConnSrv" $ do
-    (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup
-    g <- asks random
-    (connId', sq) <- withStore c $ \db -> runExceptT $ do
-      r@(connId', _) <-
-        if hasNewConn
-          then (connId,) <$> ExceptT (updateNewConnSnd db connId q)
-          else ExceptT $ createSndConn db g cData q
-      liftIO $ createRatchet db connId' rc
-      pure r
-    let cData' = (cData :: ConnData) {connId = connId'}
-    -- joinConnSrv is only used on user interaction, and its failure is permanent,
-    -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key,
-    -- similar to how joinConnAsync does that.
-    tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
-      Right sqSecured -> pure (connId', sqSecured)
-      Left e -> do
-        -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
-        void $ withStore' c $ \db -> deleteConn db Nothing connId'
-        throwE e
-joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
+    SomeConn cType conn <- withStore c (`getConn` connId)
+    case conn of
+      NewConnection _ -> doJoin Nothing
+      SndConnection _ sq -> doJoin $ Just sq
+      _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
+  where
+    doJoin :: Maybe SndQueue -> AM SndQueueSecured
+    doJoin sq_ = do
+      (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
+      secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode
+joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
   lift (compatibleContactUri cReqUri) >>= \case
     Just (qInfo, vrsn) -> do
-      (connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
-      void $ sendInvitation c userId connId' qInfo vrsn cReq cInfo
-      pure (connId', False)
+      cReq <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
+      void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
+      pure False
     Nothing -> throwE $ AGENT A_VERSION
 
 joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
@@ -906,11 +907,8 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
   where
     doJoin :: Maybe SndQueue -> AM SndQueueSecured
     doJoin sq_ = do
-      (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport
-      sq' <- withStore c $ \db -> runExceptT $ do
-        liftIO $ createRatchet db connId rc
-        maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_
-      secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode
+      (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport
+      secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode
 joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
   throwE $ CMD PROHIBITED "joinConnSrvAsync"
 
@@ -938,13 +936,13 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
     _ -> throwE $ CMD PROHIBITED "allowConnection"
 
 -- | Accept contact (ACPT command) in Reader monad
-acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
+acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
 acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
   Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      joinConn c userId connId False enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
+      joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
         withStore' c (`unacceptInvitation` invId)
         throwE err
     _ -> throwE $ CMD PROHIBITED "acceptContact"
@@ -1171,7 +1169,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
           tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
-            (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
+            cReq <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
             notify $ INV (ACR cMode cReq)
         JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
           let initUsed = [qServer q]
@@ -1681,14 +1679,21 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
     _ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex"
 
 ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM ()
-ackQueueMessage c rq@RcvQueue {userId, server} srvMsgId = do
+ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do
   atomically $ incSMPServerStat c userId server ackAttempts
   tryAgentError (sendAck c rq srvMsgId) >>= \case
-    Right _ -> atomically $ incSMPServerStat c userId server ackMsgs
-    Left (SMP _ SMP.NO_MSG) -> atomically $ incSMPServerStat c userId server ackNoMsgErrs
+    Right _ -> sendMsgNtf ackMsgs
+    Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs
     Left e -> do
       unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs
       throwE e
+  where
+    sendMsgNtf stat = do
+      atomically $ incSMPServerStat c userId server stat
+      whenM (liftIO $ hasGetLock c rq) $ do
+        atomically $ releaseGetLock c rq
+        brokerTs_ <- eitherToMaybe <$> tryAgentError (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId)
+        atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_)
 
 -- | Suspend SMP agent connection (OFF command) in Reader monad
 suspendConnection' :: AgentClient -> ConnId -> AM ()
@@ -2285,12 +2290,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
             atomically $ incSMPServerStat c userId srv recvMsgs
             void . handleNotifyAck $ do
               msg' <- decryptSMPMessage rq msg
-              ack' <- handleNotifyAck $ case msg' of
+              handleNotifyAck $ case msg' of
                 SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
                 SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
-              whenM (liftIO $ hasGetLock c rq) $
-                notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg')
-              pure ack'
             where
               queueDrained = case conn of
                 DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ A_QCONT (sndAddress rq)

src/Simplex/Messaging/Agent/Client.hs

@@ -92,6 +92,7 @@ module Simplex.Messaging.Agent.Client
     hasActiveSubscription,
     hasPendingSubscription,
     hasGetLock,
+    releaseGetLock,
     activeClientSession,
     agentClientStore,
     agentDRG,
@@ -1646,10 +1647,9 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
     queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
 
 sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
-sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
+sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
   withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
-    ackSMPMessage smp rcvPrivateKey rcvId msgId
-  atomically $ releaseGetLock c rq
+    ackSMPMessage smp rcvPrivateKey rcvId msgId      
 
 hasGetLock :: AgentClient -> RcvQueue -> IO Bool
 hasGetLock c RcvQueue {server, rcvId} =

src/Simplex/Messaging/Agent/Protocol.hs

@@ -198,7 +198,6 @@ import Simplex.Messaging.Protocol
     NMsgMeta,
     ProtocolServer (..),
     SMPClientVersion,
-    SMPMsgMeta,
     SMPServer,
     SMPServerWithAuth,
     SndPublicAuthKey,
@@ -356,7 +355,7 @@ data AEvent (e :: AEntity) where
   MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn
   MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> AEvent AEConn
   MSG :: MsgMeta -> MsgFlags -> MsgBody -> AEvent AEConn
-  MSGNTF :: SMPMsgMeta -> AEvent AEConn
+  MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn
   RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn
   QCONT :: AEvent AEConn
   DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn

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

@@ -122,6 +122,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getRcvMsg,
     getLastMsg,
     checkRcvMsgHashExists,
+    getRcvMsgBrokerTs,
     deleteMsg,
     deleteDeliveredSndMsg,
     deleteSndMsgDelivery,
@@ -1185,6 +1186,11 @@ checkRcvMsgHashExists db connId hash = do
           (connId, hash)
       )
 
+getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
+getRcvMsgBrokerTs db connId msgId =
+  firstRow fromOnly SEMsgNotFound $
+    DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId)
+
 deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
 deleteMsg db connId msgId =
   DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)

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

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

src/Simplex/Messaging/Client.hs

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

src/Simplex/Messaging/Client/Agent.hs

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

src/Simplex/Messaging/Notifications/Client.hs

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

src/Simplex/Messaging/Notifications/Server.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -23,7 +25,8 @@ import Data.Either (partitionEithers)
 import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
-import Data.List (intercalate, sort)
+import qualified Data.IntSet as IS
+import Data.List (intercalate, partition, sort)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -34,34 +37,42 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import GHC.IORef (atomicSwapIORef)
-import Network.Socket (ServiceName)
+import GHC.Stats (getRTSStats)
+import Network.Socket (ServiceName, Socket, socketToHandle)
 import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
-import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Server.Control (CPClientRole (..))
+import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats)
+import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
-import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer)
+import Simplex.Messaging.Transport.Buffer (trimCR)
+import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
-import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
+import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
+import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, async, uninterruptibleCancel, unliftIO, withFile)
 import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
+#if MIN_VERSION_base(4,18,0)
+import GHC.Conc (listThreads)
+#endif
 
 runNtfServer :: NtfServerConfig -> IO ()
 runNtfServer cfg = do
@@ -79,7 +90,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
   s <- asks subscriber
   ps <- asks pushServer
   resubscribe s
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
   where
     runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, _addHTTP) = do
@@ -152,6 +163,131 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
               ]
         liftIO $ threadDelay' interval
 
+    controlPortThread_ :: NtfServerConfig -> [M ()]
+    controlPortThread_ NtfServerConfig {controlPort = Just port} = [runCPServer port]
+    controlPortThread_ _ = []
+
+    runCPServer :: ServiceName -> M ()
+    runCPServer port = do
+      cpStarted <- newEmptyTMVarIO
+      u <- askUnliftIO
+      liftIO $ do
+        labelMyThread "control port server"
+        runLocalTCPServer cpStarted port $ runCPClient u
+      where
+        runCPClient :: UnliftIO (ReaderT NtfEnv IO) -> Socket -> IO ()
+        runCPClient u sock = do
+          labelMyThread "control port client"
+          h <- socketToHandle sock ReadWriteMode
+          hSetBuffering h LineBuffering
+          hSetNewlineMode h universalNewlineMode
+          hPutStrLn h "Ntf server control port\n'help' for supported commands"
+          role <- newTVarIO CPRNone
+          cpLoop h role
+          where
+            cpLoop h role = do
+              s <- trimCR <$> B.hGetLine h
+              case strDecode s of
+                Right CPQuit -> hClose h
+                Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role
+                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role
+            logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s
+              where
+                shouldLog = case cmd of
+                  CPAuth _ -> False
+                  CPHelp -> False
+                  CPQuit -> False
+                  CPSkip -> False
+                  _ -> True
+            processCP h role = \case
+              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+                where
+                  newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
+                    | Just auth == admin = CPRAdmin
+                    | Just auth == user = CPRUser
+                    | otherwise = CPRNone
+              CPStats -> withUserRole $ do
+                ss <- unliftIO u $ asks serverStats
+                let getStat :: (NtfServerStats -> IORef a) -> IO a
+                    getStat var = readIORef (var ss)
+                    putStat :: Show a => String -> (NtfServerStats -> IORef a) -> IO ()
+                    putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v
+                putStat "fromTime" fromTime
+                putStat "tknCreated" tknCreated
+                putStat "tknVerified" tknVerified
+                putStat "tknDeleted" tknDeleted
+                putStat "subCreated" subCreated
+                putStat "subDeleted" subDeleted
+                putStat "ntfReceived" ntfReceived
+                getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v)
+                getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v)
+              CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h)
+              CPServerInfo -> readTVarIO role >>= \case
+                CPRNone -> do
+                  logError "Unauthorized control port command"
+                  hPutStrLn h "AUTH"
+                r -> do
+#if MIN_VERSION_base(4,18,0)
+                  threads <- liftIO listThreads
+                  hPutStrLn h $ "Threads: " <> show (length threads)
+#else
+                  hPutStrLn h "Threads: not available on GHC 8.10"
+#endif
+                  NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber
+                  putSMPWorkers a "SMP subcscribers" smpSubscribers
+                  let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
+                  putSMPWorkers a "SMP clients" smpClients
+                  putSMPWorkers a "SMP subscription workers" smpSubWorkers
+                  sessions <- readTVarIO smpSessions
+                  hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions)
+                  putSMPSubs a "SMP subscriptions" srvSubs
+                  putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs
+                  where
+                    putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO ()
+                    putSMPSubs a name v = do
+                      subs <- readTVarIO v
+                      (totalCnt, ownCount, otherCnt, servers, ownByServer) <- foldM countSubs (0, 0, 0, [], M.empty) $ M.assocs subs
+                      showServers a name servers
+                      hPutStrLn h $ name <> " total: " <> show totalCnt
+                      hPutStrLn h $ name <> " on own servers: " <> show ownCount
+                      when (r == CPRAdmin && not (null ownByServer)) $
+                        forM_ (M.assocs ownByServer) $ \(SMPServer (host :| _) _ _, cnt) ->
+                          hPutStrLn h $ name <> " on " <> B.unpack (strEncode host) <> ": " <> show cnt
+                      hPutStrLn h $ name <> " on other servers: " <> show otherCnt
+                      where
+                        countSubs :: (Int, Int, Int, [SMPServer], M.Map SMPServer Int) -> (SMPServer, TMap SMPSub a) -> IO (Int, Int, Int, [SMPServer], M.Map SMPServer Int)
+                        countSubs (!totalCnt, !ownCount, !otherCnt, !servers, !ownByServer) (srv, srvSubs) = do
+                          cnt <- M.size <$> readTVarIO srvSubs
+                          let totalCnt' = totalCnt + cnt
+                              ownServer = isOwnServer a srv
+                              (ownCount', otherCnt')
+                                | ownServer = (ownCount + cnt, otherCnt)
+                                | otherwise = (ownCount, otherCnt + cnt)
+                              servers' = if cnt > 0 then srv : servers else servers
+                              ownByServer'
+                                | r == CPRAdmin && ownServer && cnt > 0 = M.alter (Just . maybe cnt (+ cnt)) srv ownByServer
+                                | otherwise = ownByServer
+                          pure (totalCnt', ownCount', otherCnt', servers', ownByServer')
+                    putSMPWorkers :: SMPClientAgent -> String -> TMap SMPServer a -> IO ()
+                    putSMPWorkers a name v = readTVarIO v >>= showServers a name . M.keys
+                    showServers :: SMPClientAgent -> String -> [SMPServer] -> IO ()
+                    showServers a name srvs = do
+                      let (ownSrvs, otherSrvs) = partition (isOwnServer a) srvs
+                      hPutStrLn h $ name <> " own servers count: " <> show (length ownSrvs)
+                      when (r == CPRAdmin) $ hPutStrLn h $ name <> " own servers: " <> intercalate "," (sort $ map (\(SMPServer (host :| _) _ _) -> B.unpack $ strEncode host) ownSrvs)
+                      hPutStrLn h $ name <> " other servers count: " <> show (length otherSrvs)
+              CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit"
+              CPQuit -> pure ()
+              CPSkip -> pure ()
+              where
+                withUserRole action =
+                  readTVarIO role >>= \case
+                    CPRAdmin -> action
+                    CPRUser -> action
+                    _ -> do
+                      logError "Unauthorized control port command"
+                      hPutStrLn h "AUTH"
+
 resubscribe :: NtfSubscriber -> M ()
 resubscribe NtfSubscriber {newSubQ} = do
   logInfo "Preparing SMP resubscriptions..."
@@ -220,9 +356,8 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
               NtfPushServer {pushQ} <- asks pushServer
               stats <- asks serverStats
               liftIO $ updatePeriodStats (activeSubs stats) ntfId
-              atomically $
-                findNtfSubscriptionToken st smpQueue
-                  >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| [])))
+              atomically (findNtfSubscriptionToken st smpQueue)
+                >>= mapM_ (\tkn -> atomically (writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| []))))
               incNtfStat ntfReceived
             Right SMP.END ->
               whenM (atomically $ activeClientSession' ca sessionId srv) $

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

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

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

@@ -28,7 +28,7 @@ import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
-import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
+import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -40,6 +40,9 @@ import UnliftIO.STM
 
 data NtfServerConfig = NtfServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
+    controlPort :: Maybe ServiceName,
+    controlPortUserAuth :: Maybe BasicAuth,
+    controlPortAdminAuth :: Maybe BasicAuth,
     subIdBytes :: Int,
     regCodeBytes :: Int,
     clientQSize :: Natural,

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

@@ -14,6 +14,7 @@ import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
@@ -85,6 +86,10 @@ ntfServerCLI cfgPath logPath =
           \# Log is compacted on start (deleted objects are removed).\n"
             <> ("enable: " <> onOff enableStoreLog <> "\n\n")
             <> "log_stats: off\n\n\
+               \[AUTH]\n\
+               \# control_port_admin_password:\n\
+               \# control_port_user_password:\n\
+               \\n\
                \[TRANSPORT]\n\
                \# Host is only used to print server address on start.\n\
                \# You can specify multiple server ports.\n"
@@ -93,6 +98,8 @@ ntfServerCLI cfgPath logPath =
             <> "log_tls_errors: off\n\n\
                \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
                \websockets: off\n\n\
+               \# control_port: 5227\n\
+               \\n\
                \[SUBSCRIBER]\n\
                \# Network configuration for notification server client.\n\
                \# `host_mode` can be 'public' (default) or 'onion'.\n\
@@ -105,6 +112,8 @@ ntfServerCLI cfgPath logPath =
                \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
                \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
                \# socks_mode: onion\n\n\
+               \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
+               \# own_server_domains: \n\n\
                \[INACTIVE_CLIENTS]\n\
                \# TTL and interval to check inactive clients\n\
                \disconnect: off\n"
@@ -128,6 +137,9 @@ ntfServerCLI cfgPath logPath =
         serverConfig =
           NtfServerConfig
             { transports = iniTransports ini,
+              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
+              controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini,
+              controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini,
               subIdBytes = 24,
               regCodeBytes = 32,
               clientQSize = 64,
@@ -143,9 +155,10 @@ ntfServerCLI cfgPath logPath =
                                 socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
                                 hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
                                 requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
-                                smpPingInterval = 60_000_000 -- 1 minutes
+                                smpPingInterval = 60_000_000 -- 1 minute
                               }
                         },
+                    ownServerDomains = either (const []) (map encodeUtf8 . T.words) $ lookupValue "SUBSCRIBER" "own_server_domains" ini,
                     persistErrorInterval = 0 -- seconds
                   },
               apnsConfig = defaultAPNSPushClientConfig,

src/Simplex/Messaging/Notifications/Transport.hs

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

src/Simplex/Messaging/Protocol.hs

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

src/Simplex/Messaging/Server.hs

@@ -38,6 +38,7 @@ module Simplex.Messaging.Server
   )
 where
 
+import Control.Concurrent.STM (throwSTM)
 import Control.Concurrent.STM.TQueue (flushTQueue)
 import Control.Logger.Simple
 import Control.Monad
@@ -52,13 +53,14 @@ import qualified Data.ByteString.Builder as BLD
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Dynamic (toDyn)
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
-import Data.List (intercalate, mapAccumR)
+import Data.List (foldl', intercalate, mapAccumR)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -70,6 +72,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
 import Data.Typeable (cast)
+import GHC.Conc.Signal
 import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import GHC.TypeLits (KnownNat)
@@ -88,6 +91,7 @@ import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.Server.MsgStore.STM
+import Simplex.Messaging.Server.NtfStore
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Server.QueueStore.STM as QS
@@ -137,22 +141,27 @@ smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M ()
 smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do
   s <- asks server
   pa <- asks proxyAgent
-  expired <- restoreServerMessages
-  restoreServerStats expired
+  expiredMsgs <- restoreServerMessages
+  expiredNtfs <- restoreServerNtfs
+  restoreServerStats expiredMsgs expiredNtfs
   raceAny_
     ( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub
         : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ())
+        : deliverNtfsThread s
         : sendPendingEvtsThread s
         : receiveFromProxyAgent pa
+        : expireNtfsThread cfg
+        : sigIntHandlerThread
         : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
     )
-    `finally` withLock' (savingLock s) "final" (saveServer False >> closeServer)
+    `finally` stopServer s
   where
     runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, addHTTP) = do
       smpCreds <- asks tlsServerCreds
       httpCreds_ <- asks httpServerCreds
-      ss <- asks sockets
+      ss <- liftIO newSocketState
+      asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
       serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
       env <- ask
       liftIO $ case (httpCreds_, attachHTTP_) of
@@ -170,8 +179,25 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
           runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
     fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
+    sigIntHandlerThread :: M ()
+    sigIntHandlerThread = do
+      flagINT <- newEmptyTMVarIO
+      let sigINT = 2 -- CONST_SIGINT value
+          sigIntAction = \_ptr -> atomically $ void $ tryPutTMVar flagINT ()
+          sigIntHandler = Just (sigIntAction, toDyn ())
+      void $ liftIO $ setHandler sigINT sigIntHandler
+      atomically $ readTMVar flagINT
+      logInfo "Received SIGINT, stopping server..."
+
+    stopServer :: Server -> M ()
+    stopServer s = do
+      asks serverActive >>= atomically . (`writeTVar` False)
+      logInfo "Saving server state..."
+      withLock' (savingLock s) "final" $ saveServer False >> closeServer
+      logInfo "Server stopped"
+
     saveServer :: Bool -> M ()
-    saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
+    saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerNtfs >> saveServerStats
 
     closeServer :: M ()
     closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
@@ -230,6 +256,50 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
         -- remove client from server's subscribed cients
         removeWhenNoSubs c = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c)
 
+    deliverNtfsThread :: Server -> M ()
+    deliverNtfsThread Server {ntfSubClients} = do
+      ntfInt <- asks $ ntfDeliveryInterval . config
+      NtfStore ns <- asks ntfStore
+      stats <- asks serverStats
+      liftIO $ forever $ do
+        threadDelay ntfInt
+        readTVarIO ntfSubClients >>= mapM_ (deliverNtfs ns stats)
+      where
+        deliverNtfs ns stats Client {clientId, ntfSubscriptions, sndQ, connected} =
+          whenM (currentClient readTVarIO) $ do
+            subs <- readTVarIO ntfSubscriptions
+            logDebug $ "NOTIFICATIONS: client #" <> tshow clientId <> " is current with " <> tshow (M.size subs) <> " subs"
+            ntfQs <- M.assocs . M.filterWithKey (\nId _ -> M.member nId subs) <$> readTVarIO ns
+            tryAny (atomically $ flushSubscribedNtfs ntfQs) >>= \case
+              Right len -> updateNtfStats len
+              Left e -> logDebug $ "NOTIFICATIONS: cancelled for client #" <> tshow clientId <> ", reason: " <> tshow e
+          where
+            flushSubscribedNtfs :: [(NotifierId, TVar [MsgNtf])] -> STM Int
+            flushSubscribedNtfs ntfQs = do
+              ts_ <- foldM addNtfs [] ntfQs
+              forM_ (L.nonEmpty ts_) $ \ts -> do
+                let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept"
+                unlessM (currentClient readTVar) $ cancelNtfs "not current client"
+                whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full"
+                writeTBQueue sndQ ts
+              pure $ length ts_
+            currentClient :: Monad m => (forall a. TVar a -> m a) -> m Bool
+            currentClient rd = (&&) <$> rd connected <*> (IM.member clientId <$> rd ntfSubClients)
+            addNtfs :: [Transmission BrokerMsg] -> (NotifierId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg]
+            addNtfs acc (nId, v) =
+              readTVar v >>= \case
+                [] -> pure acc
+                ntfs -> do
+                  writeTVar v []
+                  pure $ foldl' (\acc' ntf -> nmsg nId ntf : acc') acc ntfs -- reverses, to order by time
+            nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (CorrId "", nId, NMSG ntfNonce ntfEncMeta)
+            updateNtfStats 0 = logDebug $ "NOTIFICATIONS: no ntfs for client #" <> tshow clientId
+            updateNtfStats len = liftIO $ do
+              atomicModifyIORef'_ (ntfCount stats) (subtract len)
+              atomicModifyIORef'_ (msgNtfs stats) (+ len)
+              atomicModifyIORef'_ (msgNtfsB stats) (+ (len `div` 80 + 1)) -- up to 80 NMSG in the batch
+              logDebug $ "NOTIFICATIONS: delivered to client #" <> tshow clientId <> " " <> tshow len <> " ntfs"
+
     sendPendingEvtsThread :: Server -> M ()
     sendPendingEvtsThread s = do
       endInt <- asks $ pendingENDInterval . config
@@ -259,8 +329,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
             updateEndStats = do
               stats <- asks serverStats
               let len = L.length qEvts
-              liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
-              liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch
+              when (len > 0) $ liftIO $ do
+                atomicModifyIORef'_ (qSubEnd stats) (+ len)
+                atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch
 
     receiveFromProxyAgent :: ProxyAgent -> M ()
     receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} =
@@ -294,6 +365,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
           deleted <- liftIO $ deleteExpiredMsgs q old
           liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted)
 
+    expireNtfsThread :: ServerConfig -> M ()
+    expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do
+      ns <- asks ntfStore
+      let interval = checkInterval expCfg * 1000000
+      stats <- asks serverStats
+      labelMyThread "expireNtfsThread"
+      liftIO $ forever $ do
+        threadDelay' interval
+        old <- expireBeforeEpoch expCfg
+        expired <- deleteExpiredNtfs ns old
+        when (expired > 0) $ do
+          atomicModifyIORef'_ (msgNtfExpired stats) (+ expired)
+          atomicModifyIORef'_ (ntfCount stats) (subtract expired)
+
     serverStatsThread_ :: ServerConfig -> [M ()]
     serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
       [logServerStats logStatsStartTime interval serverStatsLogFile]
@@ -305,7 +390,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv}
+      ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv}
         <- asks serverStats
       QueueStore {queues, notifiers} <- asks queueStore
       let interval = 1000000 * logInterval
@@ -351,8 +436,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
           msgRecvNtf' <- atomicSwapIORef msgRecvNtf 0
           psNtf <- liftIO $ periodStatCounts activeQueuesNtf ts
           msgNtfs' <- atomicSwapIORef (msgNtfs ss) 0
+          msgNtfsB' <- atomicSwapIORef (msgNtfsB ss) 0
           msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0
           msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0
+          msgNtfExpired' <- atomicSwapIORef (msgNtfExpired ss) 0
           pRelays' <- getResetProxyStatsData pRelays
           pRelaysOwn' <- getResetProxyStatsData pRelaysOwn
           pMsgFwds' <- getResetProxyStatsData pMsgFwds
@@ -360,8 +447,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
           pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0
           qCount' <- readIORef qCount
           qCount'' <- M.size <$> readTVarIO queues
-          ntfCount' <- M.size <$> readTVarIO notifiers
+          notifierCount' <- M.size <$> readTVarIO notifiers
           msgCount' <- readIORef msgCount
+          ntfCount' <- readIORef ntfCount
           hPutStrLn h $
             intercalate
               ","
@@ -418,13 +506,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
                        show ntfSub',
                        show ntfSubAuth',
                        show ntfSubDuplicate',
-                       show ntfCount',
+                       show notifierCount',
                        show qDeletedAllB',
                        show qSubAllB',
                        show qSubEnd',
                        show qSubEndB',
                        show ntfDeletedB',
-                       show ntfSubB'
+                       show ntfSubB',
+                       show msgNtfsB',
+                       show msgNtfExpired',
+                       show ntfCount'
                      ]
               )
         liftIO $ threadDelay' interval
@@ -501,6 +592,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
                   hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
               CPStats -> withUserRole $ do
                 ss <- unliftIO u $ asks serverStats
+                QueueStore {queues, notifiers} <- unliftIO u $ asks queueStore
                 let getStat :: (ServerStats -> IORef a) -> IO a
                     getStat var = readIORef (var ss)
                     putStat :: Show a => String -> (ServerStats -> IORef a) -> IO ()
@@ -529,13 +621,27 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
                 putStat "msgRecv" msgRecv
                 putStat "msgRecvGet" msgRecvGet
                 putStat "msgGet" msgGet
-                putStat "msgGetNoMsg" msgGet
+                putStat "msgGetNoMsg" msgGetNoMsg
                 gets <- (,,) <$> getStat msgGetAuth <*> getStat msgGetDuplicate <*> getStat msgGetProhibited
                 hPutStrLn h $ "other GET events (auth, duplicate, prohibited): " <> show gets
                 putStat "msgSentNtf" msgSentNtf
                 putStat "msgRecvNtf" msgRecvNtf
+                putStat "msgNtfs" msgNtfs
+                putStat "msgNtfsB" msgNtfsB
+                putStat "msgNtfExpired" msgNtfExpired
                 putStat "qCount" qCount
+                qCount2 <- M.size <$> readTVarIO queues
+                hPutStrLn h $ "qCount 2: " <> show qCount2
+                notifierCount <- M.size <$> readTVarIO notifiers
+                hPutStrLn h $ "notifiers: " <> show notifierCount
                 putStat "msgCount" msgCount
+                putStat "ntfCount" ntfCount
+                readTVarIO role >>= \case
+                  CPRAdmin -> do
+                    NtfStore ns <- unliftIO u $ asks ntfStore
+                    ntfCount2 <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< readTVarIO ns
+                    hPutStrLn h $ "ntfCount 2: " <> show ntfCount2
+                  _ -> pure ()
                 putProxyStat "pRelays" pRelays
                 putProxyStat "pRelaysOwn" pRelaysOwn
                 putProxyStat "pMsgFwds" pMsgFwds
@@ -553,25 +659,28 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
 #else
                 hPutStrLn h "Not available on GHC 8.10"
 #endif
-              CPSockets -> withUserRole $ do
-                (accepted', closed', active') <- unliftIO u $ asks sockets
-                (accepted, closed, active) <- (,,) <$> readTVarIO accepted' <*> readTVarIO closed' <*> readTVarIO active'
-                hPutStrLn h "Sockets: "
-                hPutStrLn h $ "accepted: " <> show accepted
-                hPutStrLn h $ "closed: " <> show closed
-                hPutStrLn h $ "active: " <> show (IM.size active)
-                hPutStrLn h $ "leaked: " <> show (accepted - closed - IM.size active)
+              CPSockets -> withUserRole $ unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSockets
+                where
+                  putSockets (tcpPort, (accepted', closed', active')) = do
+                    (accepted, closed, active) <- (,,) <$> readTVarIO accepted' <*> readTVarIO closed' <*> readTVarIO active'
+                    hPutStrLn h $ "Sockets for port " <> tcpPort <> ":"
+                    hPutStrLn h $ "accepted: " <> show accepted
+                    hPutStrLn h $ "closed: " <> show closed
+                    hPutStrLn h $ "active: " <> show (IM.size active)
+                    hPutStrLn h $ "leaked: " <> show (accepted - closed - IM.size active)
               CPSocketThreads -> withAdminRole $ do
 #if MIN_VERSION_base(4,18,0)
-                (_, _, active') <- unliftIO u $ asks sockets
-                active <- readTVarIO active'
-                forM_ (IM.toList active) $ \(sid, tid') ->
-                  deRefWeak tid' >>= \case
-                    Nothing -> hPutStrLn h $ intercalate "," [show sid, "", "gone", ""]
-                    Just tid -> do
-                      label <- threadLabel tid
-                      status <- threadStatus tid
-                      hPutStrLn h $ intercalate "," [show sid, show tid, show status, fromMaybe "" label]
+                unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSocketThreads
+                where
+                  putSocketThreads (tcpPort, (_, _, active')) = do
+                    active <- readTVarIO active'
+                    forM_ (IM.toList active) $ \(sid, tid') ->
+                      deRefWeak tid' >>= \case
+                        Nothing -> hPutStrLn h $ intercalate "," [tcpPort, show sid, "", "gone", ""]
+                        Just tid -> do
+                          label <- threadLabel tid
+                          status <- threadStatus tid
+                          hPutStrLn h $ intercalate "," [tcpPort, show sid, show tid, show status, fromMaybe "" label]
 #else
                 hPutStrLn h "Not available on GHC 8.10"
 #endif
@@ -601,24 +710,24 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
                     hPutStrLn h $ "Ntf subscriptions (via clients): " <> show ntfSubCnt
                     hPutStrLn h $ "Ntf subscribed clients (via clients): " <> show ntfClCnt
                     hPutStrLn h $ "Ntf subscribed clients queues (via clients, rcvQ, sndQ, msgQ): " <> show ntfClQs
-                  putActiveClientsInfo "SMP" subscribers
-                  putActiveClientsInfo "Ntf" notifiers
-                  putSubscribedClients "SMP" subClients
-                  putSubscribedClients "Ntf" ntfSubClients
+                  putActiveClientsInfo "SMP" subscribers False
+                  putActiveClientsInfo "Ntf" notifiers True
+                  putSubscribedClients "SMP" subClients False
+                  putSubscribedClients "Ntf" ntfSubClients True
                   where
-                    putActiveClientsInfo :: String -> TMap QueueId (TVar Client) -> IO ()
-                    putActiveClientsInfo protoName clients = do
+                    putActiveClientsInfo :: String -> TMap QueueId (TVar Client) -> Bool -> IO ()
+                    putActiveClientsInfo protoName clients showIds = do
                       activeSubs <- readTVarIO clients
                       hPutStrLn h $ protoName <> " subscriptions: " <> show (M.size activeSubs)
-                      clCnt <- IS.size <$> countSubClients activeSubs
-                      hPutStrLn h $ protoName <> " subscribed clients: " <> show clCnt
+                      clnts <- countSubClients activeSubs
+                      hPutStrLn h $ protoName <> " subscribed clients: " <> show (IS.size clnts) <> (if showIds then " " <> show (IS.toList clnts) else "")
                       where
                         countSubClients :: M.Map QueueId (TVar Client) -> IO IS.IntSet
                         countSubClients = foldM (\ !s c -> (`IS.insert` s) . clientId <$> readTVarIO c) IS.empty
-                    putSubscribedClients :: String -> TVar (IM.IntMap Client) -> IO ()
-                    putSubscribedClients protoName subClnts = do
+                    putSubscribedClients :: String -> TVar (IM.IntMap Client) -> Bool -> IO ()
+                    putSubscribedClients protoName subClnts showIds = do
                       clnts <- readTVarIO subClnts
-                      hPutStrLn h $ protoName <> " subscribed clients count:" <> show (IM.size clnts)
+                      hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (IM.size clnts) <> (if showIds then " " <> show (IM.keys clnts) else "")
                     countClientSubs :: (Client -> TMap QueueId a) -> Maybe (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap (Maybe Client) -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
                     countClientSubs subSel countSubs_ = foldM addSubs (0, (0, 0, 0, 0), 0, (0, 0, 0))
                       where
@@ -726,12 +835,13 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connecte
   subs <- atomically $ swapTVar subscriptions M.empty
   ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty
   liftIO $ mapM_ cancelSub subs
-  Server {subscribers, notifiers, subClients, ntfSubClients} <- asks server
-  liftIO $ updateSubscribers subs subscribers
-  liftIO $ updateSubscribers ntfSubs notifiers
-  asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
-  atomically $ modifyTVar' subClients $ IM.delete clientId
-  atomically $ modifyTVar' ntfSubClients $ IM.delete clientId
+  whenM (asks serverActive >>= readTVarIO) $ do
+    Server {subscribers, notifiers, subClients, ntfSubClients} <- asks server
+    liftIO $ updateSubscribers subs subscribers
+    liftIO $ updateSubscribers ntfSubs notifiers
+    asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
+    atomically $ modifyTVar' subClients $ IM.delete clientId
+    atomically $ modifyTVar' ntfSubClients $ IM.delete clientId
   tIds <- atomically $ swapTVar endThreads IM.empty
   liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds
   where
@@ -758,8 +868,10 @@ cancelSub s = case subThread s of
 receive :: Transport c => THandleSMP c 'TServer -> Client -> M ()
 receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
+  sa <- asks serverActive
   forever $ do
     ts <- L.toList <$> liftIO (tGet h)
+    unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
     atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime
     stats <- asks serverStats
     (errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts
@@ -859,7 +971,7 @@ verifyTransmission auth_ tAuth authorized queueId cmd =
     Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
     Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient
     -- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command
-    Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender
+    Cmd SSender (SKEY k) -> verifyQueue (\q -> if maybe True (k ==) (senderKey q) then Just q `verifiedWith` k else dummyVerify) <$> get SSender
     Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender
     Cmd SSender PING -> pure $ VRVerified Nothing
     Cmd SSender RFWD {} -> pure $ VRVerified Nothing
@@ -932,7 +1044,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
   mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
 
 client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
-client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do
+client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
   forever $
     atomically (readTBQueue rcvQ)
@@ -1135,8 +1247,11 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
           liftIO (deleteQueueNotifier st entId) >>= \case
             Right (Just nId) -> do
               -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
+              stats <- asks serverStats
+              deleted <- asks ntfStore >>= liftIO . (`deleteNtfs` nId)
+              when (deleted > 0) $ liftIO $ atomicModifyIORef'_ (ntfCount stats) (subtract deleted)
               atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
-              incStat . ntfDeleted =<< asks serverStats
+              incStat $ ntfDeleted stats
               pure ok
             Right Nothing -> pure ok
             Left e -> pure $ err e
@@ -1276,7 +1391,14 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
               Message {msgFlags} -> do
                 stats <- asks serverStats
                 incStat $ msgRecv stats
-                when isGet $ incStat $ msgRecvGet stats
+                if isGet
+                  then incStat $ msgRecvGet stats
+                  else pure () -- TODO skip notification delivery for delivered message  
+                  -- skipping delivery fails tests, it should be counted in msgNtfSkipped
+                  -- forM_ (notifierId <$> notifier qr) $ \nId -> do
+                  --   ns <- asks ntfStore
+                  --   atomically $ TM.lookup nId ns >>=
+                  --     mapM_ (\MsgNtf {ntfMsgId} -> when (msgId == msgId') $ TM.delete nId ns)
                 liftIO $ atomicModifyIORef'_ (msgCount stats) (subtract 1)
                 liftIO $ updatePeriodStats (activeQueues stats) entId
                 when (notification msgFlags) $ do
@@ -1310,7 +1432,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
                         Just (msg, wasEmpty) -> time "SEND ok" $ do
                           when wasEmpty $ liftIO $ tryDeliverMessage msg
                           when (notification msgFlags) $ do
-                            mapM_ (`trySendNotification` msg) (notifier qr)
+                            mapM_ (`enqueueNotification` msg) (notifier qr)
                             incStat $ msgSentNtf stats
                             liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
                           incStat $ msgSent stats
@@ -1395,39 +1517,21 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
                             deliver q s
                             writeTVar st NoSub
 
-            trySendNotification :: NtfCreds -> Message -> M ()
-            trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg = do
-              stats <- asks serverStats
-              liftIO (TM.lookupIO notifierId notifiers) >>= \case
-                Nothing -> do
-                  incStat $ msgNtfNoSub stats
-                  logWarn "No notification subscription"
-                Just ntfClnt -> do
-                  let updateStats True = incStat $ msgNtfs stats
-                      updateStats _ = do
-                        incStat $ msgNtfLost stats
-                        logWarn "Dropped message notification"
-                  writeNtf notifierId msg rcvNtfDhSecret ntfClnt >>= mapM_ updateStats
+            enqueueNotification :: NtfCreds -> Message -> M ()
+            enqueueNotification _ MessageQuota {} = pure ()
+            enqueueNotification NtfCreds {notifierId = nId, rcvNtfDhSecret} Message {msgId, msgTs} = do
+              -- stats <- asks serverStats
+              ns <- asks ntfStore
+              ntf <- mkMessageNotification msgId msgTs rcvNtfDhSecret
+              liftIO $ storeNtf ns nId ntf
+              incStat . ntfCount =<< asks serverStats
 
-            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar Client -> M (Maybe Bool)
-            writeNtf nId msg rcvNtfDhSecret ntfClnt = case msg of
-              Message {msgId, msgTs} -> Just <$> do
-                (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret
-                -- must be in one STM transaction to avoid the queue becoming full between the check and writing
-                atomically $ do
-                  Client {sndQ = q} <- readTVar ntfClnt
-                  ifM
-                    (isFullTBQueue q)
-                    (pure $ False)
-                    (True <$ writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)])
-              _ -> pure Nothing
-
-            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M (C.CbNonce, EncNMsgMeta)
+            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M MsgNtf
             mkMessageNotification msgId msgTs rcvNtfDhSecret = do
-              cbNonce <- atomically . C.randomCbNonce =<< asks random
+              ntfNonce <- atomically . C.randomCbNonce =<< asks random
               let msgMeta = NMsgMeta {msgId, msgTs}
-                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
-              pure . (cbNonce,) $ fromRight "" encNMsgMeta
+                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret ntfNonce (smpEncode msgMeta) 128
+              pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta}
 
         processForwardedCommand :: EncFwdTransmission -> M BrokerMsg
         processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do
@@ -1528,9 +1632,12 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
                 -- queue is usually deleted by the same client that is currently subscribed,
                 -- we delete subscription here, so the client with no subscriptions can be disconnected.
                 TM.delete entId subscriptions
-              forM_ (notifierId <$> notifier q) $ \nId ->
+              forM_ (notifierId <$> notifier q) $ \nId -> do
                 -- queue is deleted by a different client from the one subscribed to notifications,
                 -- so we don't need to remove subscription from the current client.
+                stats <- asks serverStats
+                deleted <- asks ntfStore >>= liftIO . (`deleteNtfs` nId)
+                when (deleted > 0) $ liftIO $ atomicModifyIORef'_ (ntfCount stats) (subtract deleted)
                 atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
               updateDeletedStats q
               pure ok
@@ -1657,6 +1764,50 @@ restoreServerMessages =
             msgErr :: Show e => String -> e -> String
             msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
 
+saveServerNtfs :: M ()
+saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs
+  where
+    saveNtfs f = do
+      logInfo $ "saving notifications to file " <> T.pack f
+      NtfStore ns <- asks ntfStore
+      liftIO . withFile f WriteMode $ \h ->
+        readTVarIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs
+      logInfo "notifications saved"
+      where
+        -- reverse on save, to save notifications in order, will become reversed again when restoring.
+        saveQueueNtfs h (nId, v) = BLD.hPutBuilder h . encodeNtfs nId . reverse =<< readTVarIO v
+        encodeNtfs nId = mconcat . map (\ntf -> BLD.byteString (strEncode $ NLRv1 nId ntf) <> BLD.char8 '\n')
+
+restoreServerNtfs :: M Int
+restoreServerNtfs =
+  asks (storeNtfsFile . config) >>= \case
+    Just f -> ifM (doesFileExist f) (restoreNtfs f) (pure 0)
+    Nothing -> pure 0
+  where
+    restoreNtfs f = do
+      logInfo $ "restoring notifications from file " <> T.pack f
+      ns <- asks ntfStore
+      old <- asks (notificationExpiration . config) >>= liftIO . expireBeforeEpoch
+      runExceptT (liftIO (LB.readFile f) >>= foldM (restoreNtf ns old) 0 . LB.lines) >>= \case
+        Left e -> do
+          logError . T.pack $ "error restoring notifications: " <> e
+          liftIO exitFailure
+        Right expired -> do
+          renameFile f $ f <> ".bak"
+          logInfo "notifications restored"
+          pure expired
+      where
+        restoreNtf ns old !expired s' = do
+          NLRv1 nId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s
+          liftIO $ addToNtfs nId ntf
+          where
+            s = LB.toStrict s'
+            addToNtfs nId ntf@MsgNtf {ntfTs}
+              | systemSeconds ntfTs < old = pure (expired + 1)
+              | otherwise = storeNtf ns nId ntf $> expired
+            ntfErr :: Show e => String -> e -> String
+            ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
+
 saveServerStats :: M ()
 saveServerStats =
   asks (serverStatsBackupFile . config)
@@ -1667,8 +1818,8 @@ saveServerStats =
       B.writeFile f $ strEncode stats
       logInfo "server stats saved"
 
-restoreServerStats :: Int -> M ()
-restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+restoreServerStats :: Int -> Int -> M ()
+restoreServerStats expiredMsgs expiredNtfs = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
       logInfo $ "restoring server stats from file " <> T.pack f
@@ -1677,7 +1828,9 @@ restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config)
           s <- asks serverStats
           _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore
           _msgCount <- liftIO . foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 =<< readTVarIO =<< asks msgStore
-          liftIO $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring}
+          NtfStore ns <- asks ntfStore
+          _ntfCount <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< readTVarIO ns
+          liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired d + expiredMsgs, _msgNtfExpired = _msgNtfExpired d + expiredNtfs}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
           when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount

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

@@ -38,6 +38,7 @@ import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
 import Simplex.Messaging.Server.MsgStore.STM
+import Simplex.Messaging.Server.NtfStore
 import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.Stats
@@ -61,6 +62,7 @@ data ServerConfig = ServerConfig
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
     storeMsgsFile :: Maybe FilePath,
+    storeNtfsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
     -- | simple password that the clients need to pass in handshake to be able to create new queues
@@ -70,6 +72,8 @@ data ServerConfig = ServerConfig
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
+    -- | notification expiration interval (seconds)
+    notificationExpiration :: 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,
@@ -82,6 +86,8 @@ data ServerConfig = ServerConfig
     serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
     serverStatsBackupFile :: Maybe FilePath,
+    -- | notification delivery interval
+    ntfDeliveryInterval :: Int,
     -- | interval between sending pending END events to unsubscribed clients, seconds
     pendingENDInterval :: Int,
     smpCredentials :: ServerCredentials,
@@ -110,6 +116,16 @@ defaultMessageExpiration =
       checkInterval = 43200 -- seconds, 12 hours
     }
 
+defNtfExpirationHours :: Int64
+defNtfExpirationHours = 24
+
+defaultNtfExpiration :: ExpirationConfig
+defaultNtfExpiration =
+  ExpirationConfig
+    { ttl = defNtfExpirationHours * 3600, -- seconds
+      checkInterval = 3600 -- seconds, 1 hour
+    }
+
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
@@ -122,17 +138,19 @@ defaultProxyClientConcurrency = 32
 
 data Env = Env
   { config :: ServerConfig,
+    serverActive :: TVar Bool,
     serverInfo :: ServerInformation,
     server :: Server,
     serverIdentity :: KeyHash,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
+    ntfStore :: NtfStore,
     random :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
     tlsServerCreds :: T.Credential,
     httpServerCreds :: Maybe T.Credential,
     serverStats :: ServerStats,
-    sockets :: SocketState,
+    sockets :: TVar [(ServiceName, SocketState)],
     clientSeq :: TVar ClientId,
     clients :: TVar (IntMap (Maybe Client)),
     proxyAgent :: ProxyAgent -- senders served on this proxy
@@ -226,9 +244,11 @@ newProhibitedSub = do
 
 newEnv :: ServerConfig -> IO Env
 newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
+  serverActive <- newTVarIO True
   server <- newServer
   queueStore <- newQueueStore
   msgStore <- newMsgStore
+  ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
   storeLog <-
     forM storeLogFile $ \f -> do
@@ -240,11 +260,11 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg
   Fingerprint fp <- loadFingerprint smpCredentials
   let serverIdentity = KeyHash fp
   serverStats <- newServerStats =<< getCurrentTime
-  sockets <- newSocketState
+  sockets <- newTVarIO []
   clientSeq <- newTVarIO 0
   clients <- newTVarIO mempty
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure Env {serverActive, config, serverInfo, server, serverIdentity, queueStore, msgStore, ntfStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
   where
     getCredentials protocol creds = do
       files <- missingCreds

src/Simplex/Messaging/Server/Information.hs

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

src/Simplex/Messaging/Server/Main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -13,8 +14,9 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
+import Control.Exception (finally)
 import Control.Logger.Simple
-import Control.Monad (void, when, (<$!>))
+import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, toUpper)
@@ -25,7 +27,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (encodeUtf8, decodeLatin1)
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
@@ -38,15 +40,16 @@ import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
 import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
 import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency)
+import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
 import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange)
-import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
 import Simplex.Messaging.Version (mkVersionRange)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
@@ -93,6 +96,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       | scripted = initialize opts
       | otherwise = do
           putStrLn "Use `smp-server init -h` for available options."
+          checkInitOptions opts
           void $ withPrompt "SMP server will be initialized (press Enter)" getLine
           enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
           logStats <- onOffPrompt "Enable logging daily statistics" False
@@ -108,7 +112,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 logStats,
                 fqdn = if null host' then fqdn else Just host',
                 password,
-                sourceCode = (T.pack <$> sourceCode') <|> src',
+                sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource),
                 webStaticPath = if null staticPath' then sp' else Just staticPath',
                 disableWeb = noWeb'
               }
@@ -122,7 +126,18 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               case strDecode $ encodeUtf8 $ T.pack s of
                 Right auth -> pure . Just $ ServerPassword auth
                 _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
-        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password, sourceCode, webStaticPath, disableWeb} = do
+        checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do
+          let err_
+                | isNothing sourceCode && hasServerInfo serverInfo = 
+                    Just "Error: passing any server information requires passing --source-code"
+                | isNothing (operator serverInfo) && isJust operatorCountry =
+                    Just "Error: passing --operator-country requires passing --operator"
+                | isNothing (hosting serverInfo) && isJust hostingCountry =
+                    Just "Error: passing --hosting-country requires passing --hosting"
+                | otherwise = Nothing
+          forM_ err_ $ \err -> putStrLn err >> exitFailure
+        initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
+          checkInitOptions opts'
           clearDirIfExists cfgPath
           clearDirIfExists logPath
           createDirectoryIfMissing True cfgPath
@@ -130,9 +145,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
           fp <- createServerX509 cfgPath x509cfg
           basicAuth <- mapM createServerPassword password
+          controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd
           let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
               srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
-          T.writeFile iniFile $ iniFileContent host basicAuth $ Just "https://github.com/simplex-chat/simplexmq"
+          T.writeFile iniFile $ iniFileContent host basicAuth controlPortPwds
           putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "."
           putStrLn $ "Run `" <> executableName <> " start` to start server."
           warnCAPrivateKeyFile cfgPath x509cfg
@@ -141,9 +157,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           where
             createServerPassword = \case
               ServerPassword s -> pure s
-              SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom)
-            iniFileContent host basicAuth sourceCode' =
-              informationIniContent sourceCode'
+              SPRandom -> BasicAuth <$> randomBase64 32
+            randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
+            iniFileContent host basicAuth controlPortPwds =
+              informationIniContent opts'
                 <> "[STORE_LOG]\n\
                    \# The server uses STM memory for persistence,\n\
                    \# that will be lost on restart (e.g., as with redis).\n\
@@ -154,7 +171,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
                    \# they are preserved in the .bak file until the next restart.\n"
                 <> ("restore_messages: " <> onOff enableStoreLog <> "\n")
-                <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n\n")
+                <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
+                <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
                 <> "# Log daily server statistics to CSV file\n"
                 <> ("log_stats: " <> onOff logStats <> "\n\n")
                 <> "[AUTH]\n\
@@ -166,13 +184,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                    \# smp://fingerprint:password@host1,host2\n\
                    \# The password will not be shared with the connecting contacts, you must share it only\n\
                    \# with the users who you want to allow creating messaging queues on your server.\n"
-                <> ( case basicAuth of
-                      Just auth -> "create_password: " <> safeDecodeUtf8 (strEncode auth)
-                      _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
+                <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')"
+                      in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth
                    )
-                <> "\n\n\
-                   \# control_port_admin_password:\n\
-                   \# control_port_user_password:\n\n\
+                <> "\n\n"
+                <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
+                <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
+                <> "\n\
                    \[TRANSPORT]\n\
                    \# Host is only used to print server address on start.\n\
                    \# You can specify multiple server ports.\n"
@@ -180,38 +198,44 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 <> ("port: " <> T.pack defaultServerPorts <> "\n")
                 <> "log_tls_errors: off\n\n\
                    \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
-                   \websockets: off\n\
-                   \# control_port: 5224\n\n\
+                   \# This option is deprecated and should be used for testing only.\n\
+                   \# , port 443 should be specified in port above\n\
+                   \websockets: off\n"
+                <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort))
+                <> "\n\n\
                    \[PROXY]\n\
                    \# Network configuration for SMP proxy client.\n\
                    \# `host_mode` can be 'public' (default) or 'onion'.\n\
                    \# It defines prefferred hostname for destination servers with multiple hostnames.\n\
                    \# host_mode: public\n\
                    \# required_host_mode: off\n\n\
-                   \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
-                   \# own_server_domains: \n\n\
+                   \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n"
+                <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains)
+                <> "\n\n\
                    \# SOCKS proxy port for forwarding messages to destination servers.\n\
-                   \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
-                   \# socks_proxy: localhost:9050\n\n\
+                   \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n"
+                <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy)
+                <> "\n\n\
                    \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
                    \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
                    \# socks_mode: onion\n\n\
                    \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
-                <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency <> "\n\n")
-                <> "[INACTIVE_CLIENTS]\n\
+                <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency)
+                <> "\n\n\
+                   \[INACTIVE_CLIENTS]\n\
                    \# TTL and interval to check inactive clients\n\
-                   \disconnect: off\n"
-                <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
-                <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
+                   \disconnect: on\n"
+                <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
+                <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration))
                 <> "\n\n\
                    \[WEB]\n\
                    \# Set path to generate static mini-site for server information and qr codes/links\n"
                 <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")
                 <> "# Run an embedded server on this port\n\
                    \# Onion sites can use any port and register it in the hidden service config.\n\
-                   \# Running on a port 80 may require setting process capabilities.\n"
-                <> (webDisabled <> "http: 8000\n\n")
-                <> "# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
+                   \# Running on a port 80 may require setting process capabilities.\n\
+                   \# http: 8000\n\n\
+                   \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
                    \# Not required for running relay on onion address.\n"
                 <> (webDisabled <> "https: 443\n")
                 <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
@@ -257,17 +281,25 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       case webStaticPath' of
         Just path | sharedHTTP -> do
           runWebServer path Nothing ServerInformation {config, information}
-          attachStaticFiles path $ \attachHTTP -> runSMPServer cfg $ Just attachHTTP
+          attachStaticFiles path $ \attachHTTP -> do
+            logDebug "Allocated web server resources"
+            runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
         Just path -> do
           runWebServer path webHttpsParams' ServerInformation {config, information}
           runSMPServer cfg Nothing
         Nothing -> do
           logWarn "No server static path set"
           runSMPServer cfg Nothing
+      logDebug "Bye"
       where
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
+        restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of
+          Just True -> Just path
+          Just False -> Nothing
+          -- if the setting is not set, it is enabled when store log is enabled
+          _ -> enableStoreLog $> path
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
         serverConfig =
@@ -286,13 +318,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
               storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile =
-                let messagesPath = combine logPath "smp-server-messages.log"
-                 in case iniOnOff "STORE_LOG" "restore_messages" ini of
-                      Just True -> Just messagesPath
-                      Just False -> Nothing
-                      -- if the setting is not set, it is enabled when store log is enabled
-                      _ -> enableStoreLog $> messagesPath,
+              storeMsgsFile = restoreMessagesFile $ combine logPath "smp-server-messages.log",
+              storeNtfsFile = restoreMessagesFile $ combine logPath "smp-server-ntfs.log",
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
               newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
@@ -303,6 +330,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   defaultMessageExpiration
                     { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                     },
+              notificationExpiration =
+                defaultNtfExpiration
+                  { ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
+                  },
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
                   $> ExpirationConfig
@@ -314,6 +345,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
               pendingENDInterval = 15000000, -- 15 seconds
+              ntfDeliveryInterval = 3000000, -- 3 seconds
               smpServerVRange = supportedServerSMPRelayVRange,
               transportConfig =
                 defaultTransportServerConfig
@@ -383,28 +415,31 @@ getServerSourceCode =
 simplexmqSource :: String
 simplexmqSource = "https://github.com/simplex-chat/simplexmq"
 
-informationIniContent :: Maybe Text -> Text
-informationIniContent sourceCode_ =
+defaultControlPort :: Int
+defaultControlPort = 5224
+
+informationIniContent :: InitOptions -> Text
+informationIniContent InitOptions {sourceCode, serverInfo} =
   "[INFORMATION]\n\
   \# AGPLv3 license requires that you make any source code modifications\n\
   \# available to the end users of the server.\n\
   \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
   \# Include correct source code URI in case the server source code is modified in any way.\n\
   \# If any other information fields are present, source code property also MUST be present.\n\n"
-    <> (maybe "# source_code: URI" ("source_code: " <>) sourceCode_ <> "\n\n")
-    <> "# Declaring all below information is optional, any of these fields can be omitted.\n\
+    <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode)
+    <> "\n\n\
+       \# Declaring all below information is optional, any of these fields can be omitted.\n\
        \\n\
        \# Server usage conditions and amendments.\n\
        \# It is recommended to use standard conditions with any amendments in a separate document.\n\
        \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\
        \# condition_amendments: link\n\
        \\n\
-       \# Server location and operator.\n\
-       \# server_country: ISO-3166 2-letter code\n\
-       \# operator: entity (organization or person name)\n\
-       \# operator_country: ISO-3166 2-letter code\n\
-       \# website:\n\
-       \\n\
+       \# Server location and operator.\n"
+    <> countryStr "server" serverCountry
+    <> enitiyStrs "operator" operator
+    <> (optDisabled website <> "website: " <> fromMaybe "" website)
+    <> "\n\n\
        \# Administrative contacts.\n\
        \# admin_simplex: SimpleX address\n\
        \# admin_email:\n\
@@ -417,9 +452,20 @@ informationIniContent sourceCode_ =
        \# complaints_pgp:\n\
        \# complaints_pgp_fingerprint:\n\
        \\n\
-       \# Hosting provider.\n\
-       \# hosting: entity (organization or person name)\n\
-       \# hosting_country: ISO-3166 2-letter code\n\n"
+       \# Hosting provider.\n"
+    <> enitiyStrs "hosting" hosting
+    <> "\n\
+       \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n"
+    <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n")
+  where
+    ServerPublicInfo {operator, website, hosting, hostingType, serverCountry}= serverInfo
+    countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n"
+    enitiyStrs optName entity =
+      optDisabled entity
+        <> optName <> ": "
+        <> maybe ("entity (organization or person name)") name entity
+        <> "\n"
+        <> countryStr optName (country =<< entity)
 
 serverPublicInfo :: Ini -> Maybe ServerPublicInfo
 serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
@@ -435,15 +481,14 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
           website = infoValue "website",
           adminContacts = iniContacts "admin_simplex" "admin_email" "admin_pgp" "admin_pgp_fingerprint",
           complaintsContacts = iniContacts "complaints_simplex" "complaints_email" "complaints_pgp" "complaints_pgp_fingerprint",
-          hosting = iniEntity "hosting" "hosting_country"
+          hosting = iniEntity "hosting" "hosting_country",
+          hostingType = either error id <$!> strDecodeIni "INFORMATION" "hosting_type" ini
         }
     infoValue name = eitherToMaybe $ lookupValue "INFORMATION" name ini
     iniEntity nameField countryField =
       (\name -> Entity {name, country = countryValue countryField})
         <$!> infoValue nameField
-    countryValue field =
-      (\cs -> if T.length cs == 2 && T.all (\c -> isAscii c && isAlpha c) cs then T.map toUpper cs else error $ "Use ISO3166 2-letter code for " <> T.unpack field)
-        <$!> infoValue field
+    countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
     iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
       let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
           email = infoValue emailField
@@ -454,6 +499,14 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
             (Nothing, Nothing, _, Nothing) -> Nothing
             (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
 
+optDisabled :: Maybe a -> Text
+optDisabled p = if isNothing p then "# " else ""
+
+validCountryValue :: String -> String -> Either String Text
+validCountryValue field s
+  | length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
+  | otherwise = Left $ "Use ISO3166 2-letter code for " <> field
+
 printSourceCode :: Maybe Text -> IO ()
 printSourceCode = \case
   Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode
@@ -474,7 +527,13 @@ data InitOptions = InitOptions
     ip :: HostName,
     fqdn :: Maybe HostName,
     password :: Maybe ServerPassword,
+    controlPort :: Maybe Int,
+    socksProxy :: Maybe SocksProxy,
+    ownDomains :: Maybe (L.NonEmpty TransportHost),
     sourceCode :: Maybe Text,
+    serverInfo :: ServerPublicInfo,
+    operatorCountry :: Maybe Text,
+    hostingCountry :: Maybe Text,
     webStaticPath :: Maybe FilePath,
     disableWeb :: Bool,
     scripted :: Bool
@@ -543,11 +602,46 @@ cliCommandP cfgPath logPath iniFile =
                   <> help "Set password to create new messaging queues"
                   <> value SPRandom
               )
+      controlPort <-
+        flag' (Just defaultControlPort) (long "control-port" <> help ("Enable control port on " <> show defaultControlPort))
+          <|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing)
+      socksProxy <-
+        flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050")
+          <|>
+            option
+              strParse
+              ( long "socks-proxy"
+                  <> metavar "PROXY"
+                  <> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
+                  <> value Nothing
+              )
+      ownDomains :: Maybe (L.NonEmpty TransportHost) <-
+        option
+          strParse
+            ( long "own-domains"
+                <> metavar "DOMAINS"
+                <> help "Own server domain names (comma-separated)"
+                <> value Nothing
+            )
       sourceCode <-
+        flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")"))
+          <|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code")
+      operator_ <- entityP "operator" "OPERATOR" "Server operator"
+      hosting_ <- entityP "hosting" "HOSTING" "Hosting provider"
+      hostingType <-
+        option
+          strParse
+          ( long "hosting-type"
+              <> metavar "HOSTING_TYPE"
+              <> help "Hosting type: virtual, dedicated, colocation, owned"
+              <> value Nothing
+          )
+      serverCountry <- countryP "server" "SERVER" "Server datacenter"
+      website <-
         (optional . strOption)
-          ( long "source-code"
-              <> help "Server source code will be communicated to the users"
-              <> metavar "URI"
+          ( long "operator-website"
+              <> help "Operator public website"
+              <> metavar "WEBSITE"
           )
       webStaticPath <-
         (optional . strOption)
@@ -574,10 +668,46 @@ cliCommandP cfgPath logPath iniFile =
             ip,
             fqdn,
             password,
-            sourceCode,
+            controlPort,
+            socksProxy,
+            ownDomains,
+            sourceCode = T.pack <$> sourceCode,
+            serverInfo =
+              ServerPublicInfo
+                { sourceCode = T.pack simplexmqSource,
+                  usageConditions = Nothing,
+                  operator = fst operator_,
+                  website,
+                  adminContacts = Nothing,
+                  complaintsContacts = Nothing,
+                  hosting = fst hosting_,
+                  hostingType,
+                  serverCountry
+                },
+            operatorCountry = snd operator_,
+            hostingCountry = snd hosting_,
             webStaticPath,
             disableWeb,
             scripted
           }
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
+    entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
+    entityP opt' metavar' help' = do
+      name_ <-
+        (optional . strOption)
+          ( long opt'
+              <> metavar (metavar' <> "_NAME")
+              <> help (help' <> " name")
+          )
+      country <- countryP opt' metavar' help'
+      pure ((\name -> Entity {name, country}) <$> name_, country)
+    countryP :: String -> String -> String -> Parser (Maybe Text)
+    countryP opt' metavar' help' =
+      (optional . option (eitherReader $ validCountryValue opt'))
+        ( long (opt' <> "-country")
+            <> metavar (metavar' <> "_COUNTRY")
+            <> help (help' <> " country")
+        )
+    strParse :: StrEncoding a => ReadM a
+    strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack

src/Simplex/Messaging/Server/NtfStore.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Server.NtfStore where
+
+import Control.Concurrent.STM
+import Control.Monad (foldM)
+import Data.Int (Int64)
+import qualified Data.Map.Strict as M
+import Data.Time.Clock.System (SystemTime (..))
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+
+newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf]))
+
+data MsgNtf = MsgNtf
+  { ntfMsgId :: MsgId,
+    ntfTs :: SystemTime,
+    ntfNonce :: C.CbNonce,
+    ntfEncMeta :: EncNMsgMeta
+  }
+
+storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO ()
+storeNtf (NtfStore ns) nId ntf = do
+  TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :))
+  -- TODO coalesce messages here once the client is updated to process multiple messages
+  -- for single notification.
+  -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats
+  where
+    newNtfs = TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :))
+
+deleteNtfs :: NtfStore -> NotifierId -> IO Int
+deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO)
+
+deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int
+deleteExpiredNtfs (NtfStore ns) old =
+  foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns
+  where
+    expireQueue nId = TM.lookupIO nId ns >>= maybe (pure 0) expire
+    expire v = readTVarIO v >>= \case
+      [] -> pure 0
+      _ ->
+        atomically $ readTVar v >>= \case
+          [] -> pure 0
+          -- check the last message first, it is the earliest
+          ntfs | systemSeconds (ntfTs $ last $ ntfs) < old -> do
+            let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs
+            writeTVar v ntfs'
+            pure $! length ntfs - length ntfs'
+          _ -> pure 0
+
+data NtfLogRecord = NLRv1 NotifierId MsgNtf
+
+instance StrEncoding MsgNtf where
+  strEncode MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta} = strEncode (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta)
+  strP = do
+    (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta) <- strP
+    pure MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta}
+
+instance StrEncoding NtfLogRecord where
+  strEncode (NLRv1 nId ntf) = strEncode (Str "v1", nId, ntf)
+  strP = "v1 " *> (NLRv1 <$> strP_ <*> strP)

src/Simplex/Messaging/Server/Stats.hs

@@ -67,15 +67,18 @@ data ServerStats = ServerStats
     msgRecvNtf :: IORef Int, -- received messages with NTF flag
     activeQueuesNtf :: PeriodStats,
     msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf)
+    msgNtfsB :: IORef Int, -- messages notication batches delivered to NTF server
     msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected)
     msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full
+    msgNtfExpired :: IORef Int, -- expired
     pRelays :: ProxyStats,
     pRelaysOwn :: ProxyStats,
     pMsgFwds :: ProxyStats,
     pMsgFwdsOwn :: ProxyStats,
     pMsgFwdsRecv :: IORef Int,
     qCount :: IORef Int,
-    msgCount :: IORef Int
+    msgCount :: IORef Int,
+    ntfCount :: IORef Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -117,15 +120,18 @@ data ServerStatsData = ServerStatsData
     _msgRecvNtf :: Int,
     _activeQueuesNtf :: PeriodStatsData,
     _msgNtfs :: Int,
+    _msgNtfsB :: Int,
     _msgNtfNoSub :: Int,
     _msgNtfLost :: Int,
+    _msgNtfExpired :: Int,
     _pRelays :: ProxyStatsData,
     _pRelaysOwn :: ProxyStatsData,
     _pMsgFwds :: ProxyStatsData,
     _pMsgFwdsOwn :: ProxyStatsData,
     _pMsgFwdsRecv :: Int,
     _qCount :: Int,
-    _msgCount :: Int
+    _msgCount :: Int,
+    _ntfCount :: Int
   }
   deriving (Show)
 
@@ -169,8 +175,10 @@ newServerStats ts = do
   msgRecvNtf <- newIORef 0
   activeQueuesNtf <- newPeriodStats
   msgNtfs <- newIORef 0
+  msgNtfsB <- newIORef 0
   msgNtfNoSub <- newIORef 0
   msgNtfLost <- newIORef 0
+  msgNtfExpired <- newIORef 0
   pRelays <- newProxyStats
   pRelaysOwn <- newProxyStats
   pMsgFwds <- newProxyStats
@@ -178,6 +186,7 @@ newServerStats ts = do
   pMsgFwdsRecv <- newIORef 0
   qCount <- newIORef 0
   msgCount <- newIORef 0
+  ntfCount <- newIORef 0
   pure
     ServerStats
       { fromTime,
@@ -218,15 +227,18 @@ newServerStats ts = do
         msgRecvNtf,
         activeQueuesNtf,
         msgNtfs,
+        msgNtfsB,
         msgNtfNoSub,
         msgNtfLost,
+        msgNtfExpired,
         pRelays,
         pRelaysOwn,
         pMsgFwds,
         pMsgFwdsOwn,
         pMsgFwdsRecv,
         qCount,
-        msgCount
+        msgCount,
+        ntfCount
       }
 
 getServerStatsData :: ServerStats -> IO ServerStatsData
@@ -269,8 +281,10 @@ getServerStatsData s = do
   _msgRecvNtf <- readIORef $ msgRecvNtf s
   _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
   _msgNtfs <- readIORef $ msgNtfs s
+  _msgNtfsB <- readIORef $ msgNtfsB s
   _msgNtfNoSub <- readIORef $ msgNtfNoSub s
   _msgNtfLost <- readIORef $ msgNtfLost s
+  _msgNtfExpired <- readIORef $ msgNtfExpired s
   _pRelays <- getProxyStatsData $ pRelays s
   _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
   _pMsgFwds <- getProxyStatsData $ pMsgFwds s
@@ -278,6 +292,7 @@ getServerStatsData s = do
   _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
   _qCount <- readIORef $ qCount s
   _msgCount <- readIORef $ msgCount s
+  _ntfCount <- readIORef $ ntfCount s
   pure
     ServerStatsData
       { _fromTime,
@@ -318,15 +333,18 @@ getServerStatsData s = do
         _msgRecvNtf,
         _activeQueuesNtf,
         _msgNtfs,
+        _msgNtfsB,
         _msgNtfNoSub,
         _msgNtfLost,
+        _msgNtfExpired,
         _pRelays,
         _pRelaysOwn,
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
         _qCount,
-        _msgCount
+        _msgCount,
+        _ntfCount
       }
 
 -- this function is not thread safe, it is used on server start only
@@ -370,8 +388,10 @@ setServerStats s d = do
   writeIORef (msgRecvNtf s) $! _msgRecvNtf d
   setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
   writeIORef (msgNtfs s) $! _msgNtfs d
+  writeIORef (msgNtfsB s) $! _msgNtfsB d
   writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d
   writeIORef (msgNtfLost s) $! _msgNtfLost d
+  writeIORef (msgNtfExpired s) $! _msgNtfExpired d
   setProxyStats (pRelays s) $! _pRelays d
   setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
   setProxyStats (pMsgFwds s) $! _pMsgFwds d
@@ -379,6 +399,7 @@ setServerStats s d = do
   writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
   writeIORef (qCount s) $! _qCount d
   writeIORef (msgCount s) $! _msgCount d
+  writeIORef (ntfCount s) $! _ntfCount d
 
 instance StrEncoding ServerStatsData where
   strEncode d =
@@ -420,8 +441,10 @@ instance StrEncoding ServerStatsData where
         "msgSentNtf=" <> strEncode (_msgSentNtf d),
         "msgRecvNtf=" <> strEncode (_msgRecvNtf d),
         "msgNtfs=" <> strEncode (_msgNtfs d),
+        "msgNtfsB=" <> strEncode (_msgNtfsB d),
         "msgNtfNoSub=" <> strEncode (_msgNtfNoSub d),
         "msgNtfLost=" <> strEncode (_msgNtfLost d),
+        "msgNtfExpired=" <> strEncode (_msgNtfExpired d),
         "activeQueues:",
         strEncode (_activeQueues d),
         "activeQueuesNtf:",
@@ -475,8 +498,10 @@ instance StrEncoding ServerStatsData where
     _msgSentNtf <- opt "msgSentNtf="
     _msgRecvNtf <- opt "msgRecvNtf="
     _msgNtfs <- opt "msgNtfs="
+    _msgNtfsB <- opt "msgNtfsB="
     _msgNtfNoSub <- opt "msgNtfNoSub="
     _msgNtfLost <- opt "msgNtfLost="
+    _msgNtfExpired <- opt "msgNtfExpired="
     _activeQueues <-
       optional ("activeQueues:" <* A.endOfLine) >>= \case
         Just _ -> strP <* optional A.endOfLine
@@ -536,8 +561,10 @@ instance StrEncoding ServerStatsData where
           _msgSentNtf,
           _msgRecvNtf,
           _msgNtfs,
+          _msgNtfsB,
           _msgNtfNoSub,
           _msgNtfLost,
+          _msgNtfExpired,
           _activeQueues,
           _activeQueuesNtf,
           _pRelays,
@@ -546,7 +573,8 @@ instance StrEncoding ServerStatsData where
           _pMsgFwdsOwn,
           _pMsgFwdsRecv,
           _qCount,
-          _msgCount = 0
+          _msgCount = 0,
+          _ntfCount = 0
         }
     where
       opt s = A.string s *> strP <* A.endOfLine <|> pure 0

src/Simplex/Messaging/Server/StoreLog.hs

@@ -9,6 +9,7 @@
 
 module Simplex.Messaging.Server.StoreLog
   ( StoreLog, -- constructors are not exported
+    StoreLogRecord (..), -- used in tests
     openWriteStoreLog,
     openReadStoreLog,
     storeLogFilePath,

src/Simplex/Messaging/TMap.hs

@@ -9,6 +9,7 @@ module Simplex.Messaging.TMap
     member,
     memberIO,
     insert,
+    insertM,
     delete,
     lookupInsert,
     lookupDelete,
@@ -62,6 +63,10 @@ insert :: Ord k => k -> a -> TMap k a -> STM ()
 insert k v m = modifyTVar' m $ M.insert k v
 {-# INLINE insert #-}
 
+insertM :: Ord k => k -> STM a -> TMap k a -> STM ()
+insertM k f m = modifyTVar' m . M.insert k =<< f
+{-# INLINE insertM #-}
+
 delete :: Ord k => k -> TMap k a -> STM ()
 delete k m = modifyTVar' m $ M.delete k
 {-# INLINE delete #-}

src/Simplex/Messaging/Transport.hs

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

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

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

src/Simplex/Messaging/Transport/Server.hs

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

tests/AgentTests/FunctionalAPITests.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -246,7 +247,9 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe
 createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn)
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
-joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId Nothing enableNtfs cReq connInfo PQSupportOn
+joinConnection c userId enableNtfs cReq connInfo subMode = do
+  connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
+  (connId,) <$> A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
 
 sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
 sendMessage c connId msgFlags msgBody = do
@@ -605,7 +608,8 @@ runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient,
 runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
-    (aliceId, sqSecured') <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
+    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
+    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
@@ -807,13 +811,12 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
   runRight_ $ do
     (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    (aliceId', sqSecuredJoin) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecuredJoin `shouldBe` False -- joining via contact address connection
+    sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` reqPQSupport
-    (bobId, sqSecured') <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+    bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
+    sqSecured' <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
     liftIO $ pqSup'' `shouldBe` bPQ
@@ -859,13 +862,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
     msgId = subtract baseId . fst
     connectViaContact b pq qInfo = do
       aId <- A.prepareConnectionToJoin b 1 True qInfo pq
-      (aId', sqSecuredJoin) <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
-      liftIO $ do
-        aId' `shouldBe` aId
-        sqSecuredJoin `shouldBe` False -- joining via contact address connection
+      sqSecuredJoin <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
+      liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
       ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
-      (bId, sqSecuredAccept) <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+      bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
+      sqSecuredAccept <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
       liftIO $ pqSup'' `shouldBe` pq
@@ -906,10 +908,8 @@ testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (aliceId', sqSecured) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecured `shouldBe` False -- joining via contact address connection
+    sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
     liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
     rejectContact alice addrConnId invId
@@ -922,10 +922,8 @@ testUpdateConnectionUserId =
     newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
     _ <- changeConnectionUser alice 1 connId newUserId
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (aliceId', sqSecured') <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecured' `shouldBe` True
+    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ sqSecured' `shouldBe` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` PQSupportOn
     allowConnection alice connId confId "alice's connInfo"
@@ -1681,34 +1679,45 @@ testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProx
   (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   liftIO $ sqSecured `shouldBe` False
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
+  getMSGNTF alice bobId
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
   getMsg bob aliceId $
     get bob ##> ("", aliceId, INFO "alice's connInfo")
+  getMSGNTF bob aliceId
   liftIO $ threadDelay 1_000000
   getMsg alice bobId $ pure ()
-  get alice ##> ("", bobId, CON)
+  inAnyOrder
+    (get alice)
+    [ \case ("", c, CON) -> c == bobId; _ -> False,
+      \case ("", c, MSGNTF {}) -> c == bobId; _ -> False
+    ]
   getMsg bob aliceId $
     get bob ##> ("", aliceId, CON)
+  getMSGNTF bob aliceId
   -- exchange messages
   4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
   get alice ##> ("", bobId, SENT 4)
   getMsg bob aliceId $
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
   ackMessage bob aliceId 4 Nothing
+  getMSGNTF bob aliceId
   5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   get bob ##> ("", aliceId, SENT 5)
   getMsg alice bobId $
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
   ackMessage alice bobId 5 Nothing
+  getMSGNTF alice bobId
 
 getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a
 getMsg c cId action = do
   liftIO $ noMessages c "nothing should be delivered before GET"
   Just _ <- getConnectionMessage c cId
-  r <- action
-  get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False
-  pure r
+  action
+
+getMSGNTF :: AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
+getMSGNTF c cId =
+  get c =##> \case ("", c', MSGNTF {}) -> c' == cId; _ -> False
 
 testOnlyCreatePull :: IO ()
 testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
@@ -1716,11 +1725,13 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   liftIO $ sqSecured `shouldBe` True
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
+  getMSGNTF alice bobId
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
   getMsg bob aliceId $ do
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
+  getMSGNTF bob aliceId
   liftIO $ threadDelay 1_000000
   get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation
   -- exchange messages
@@ -1729,11 +1740,13 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   getMsg bob aliceId $
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
   ackMessage bob aliceId 2 Nothing
+  getMSGNTF bob aliceId
   3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   get bob ##> ("", aliceId, SENT 3)
   getMsg alice bobId $
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
   ackMessage alice bobId 3 Nothing
+  getMSGNTF alice bobId
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection = makeConnection_ PQSupportOn True
@@ -1748,10 +1761,8 @@ makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> Agent
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
   (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
-  (aliceId', sqSecured') <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
-  liftIO $ do
-    aliceId' `shouldBe` aliceId
-    sqSecured' `shouldBe` sqSecured
+  sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
+  liftIO $ sqSecured' `shouldBe` sqSecured
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
   allowConnection alice bobId confId "alice's connInfo"
@@ -1995,7 +2006,7 @@ pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption)
 pattern SentB msgId <- Right (msgId, PQEncOn)
 
 receiveMsg :: AgentClient -> ConnId -> AgentMsgId -> MsgBody -> ExceptT AgentErrorType IO ()
-receiveMsg c cId msgId msg  = do
+receiveMsg c cId msgId msg = do
   get c =##> \case ("", cId', Msg' mId' PQEncOn msg') -> cId' == cId && mId' == msgId && msg' == msg; _ -> False
   ackMessage c cId msgId Nothing
 

tests/AgentTests/NotificationTests.hs

@@ -54,7 +54,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple.QQ (sql)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
-import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
+import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
@@ -134,9 +134,8 @@ notificationTests t = do
           withNtfServer t $ testChangeToken apns
   describe "Notifications server store log" $
     it "should save and restore tokens and subscriptions" $
-      withSmpServer t $
-        withAPNSMockServer $ \apns ->
-          testNotificationsStoreLog t apns
+      withAPNSMockServer $ \apns ->
+        testNotificationsStoreLog t apns
   describe "Notifications after SMP server restart" $
     it "should resume subscriptions after SMP server is restarted" $
       withAPNSMockServer $ \apns ->
@@ -183,15 +182,14 @@ runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do
   threadDelay 100000
 
 testNotificationToken :: APNSMockServer -> IO ()
-testNotificationToken APNSMockServer {apnsQ} = do
+testNotificationToken apns = do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+      getMockNotification apns tkn
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    liftIO $ sendApnsResponse APNSRespOk
     verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
     deleteNtfToken a tkn
@@ -208,48 +206,44 @@ v .-> key = do
 -- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
-testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
+testNtfTokenRepeatRegistration apns = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+      getMockNotification apns tkn
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    liftIO $ sendApnsResponse APNSRespOk
     NTRegistered <- registerNtfToken a tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
+      getMockNotification apns tkn
     _ <- ntfData' .-> "verification"
     _ <- C.cbNonce <$> ntfData' .-> "nonce"
-    liftIO $ sendApnsResponse' APNSRespOk
     -- can still use the first verification code, it is the same after decryption
     verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
     pure ()
 
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
-testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
+testNtfTokenSecondRegistration apns =
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   withAgentClients2 $ \a a' -> runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+      getMockNotification apns tkn
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    liftIO $ sendApnsResponse APNSRespOk
     verifyNtfToken a tkn nonce verification
 
     NTRegistered <- registerNtfToken a' tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
+      getMockNotification apns tkn
     verification' <- ntfData' .-> "verification"
     nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
-    liftIO $ sendApnsResponse' APNSRespOk
 
     -- at this point the first token is still active
     NTActive <- checkNtfToken a tkn
@@ -265,14 +259,13 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
     pure ()
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
+testNtfTokenServerRestart t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServerStoreLog t $ \_ -> runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+        getMockNotification apns tkn
       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
@@ -287,14 +280,13 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
       pure ()
 
 testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do
+testNtfTokenServerRestartReverify t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a -> do
     ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+        getMockNotification apns tkn
       pure ntfData
     runRight_ $ do
       verification <- ntfData .-> "verification"
@@ -311,14 +303,13 @@ testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do
       pure ()
 
 testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do
+testNtfTokenServerRestartReverifyTimeout t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     (nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+        getMockNotification apns tkn
       verification <- ntfData .-> "verification"
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       verifyNtfToken a tkn nonce verification
@@ -347,14 +338,14 @@ testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do
       pure ()
 
 testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do
+testNtfTokenServerRestartReregister t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServerStoreLog t $ \_ -> runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <-
+        getMockNotification apns tkn
+      pure ()
   -- 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
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
@@ -362,9 +353,8 @@ testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do
     -- so that repeat registration happens when client is restarted.
     withNtfServerStoreLog t $ \_ -> runRight_ $ do
       NTRegistered <- registerNtfToken a' tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+        getMockNotification apns tkn
       verification <- ntfData .-> "verification"
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       verifyNtfToken a' tkn nonce verification
@@ -372,14 +362,14 @@ testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do
       pure ()
 
 testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do
+testNtfTokenServerRestartReregisterTimeout t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     withNtfServerStoreLog t $ \_ -> runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <-
+        getMockNotification apns tkn
+      pure ()
     -- this emulates the situation when server registered token but the client did not receive the response
     withTransaction store $ \db ->
       DB.execute
@@ -398,9 +388,8 @@ testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do
     -- so that repeat registration happens when client is restarted.
     withNtfServerStoreLog t $ \_ -> runRight_ $ do
       NTRegistered <- registerNtfToken a' tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      liftIO $ sendApnsResponse APNSRespOk
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+        getMockNotification apns tkn
       verification <- ntfData .-> "verification"
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       verifyNtfToken a' tkn nonce verification
@@ -414,18 +403,17 @@ getTestNtfTokenPort a =
     Nothing -> error "no active NtfToken"
 
 testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
+testNtfTokenMultipleServers t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
     withNtfServerThreadOn t ntfTestPort $ \ntf ->
       withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
         -- register a new token, the agent picks a server and stores its choice
         NTRegistered <- registerNtfToken a tkn NMPeriodic
-        APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-          atomically $ readTBQueue apnsQ
+        APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+          getMockNotification apns tkn
         verification <- ntfData .-> "verification"
         nonce <- C.cbNonce <$> ntfData .-> "nonce"
-        liftIO $ sendApnsResponse APNSRespOk
         verifyNtfToken a tkn nonce verification
         NTActive <- checkNtfToken a tkn
         -- shut down the "other" server
@@ -439,10 +427,10 @@ testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
         pure ()
 
 testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenChangeServers t APNSMockServer {apnsQ} =
+testNtfTokenChangeServers t apns =
   withNtfServerThreadOn t ntfTestPort $ \ntf -> do
     tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
-      tkn <- registerTestToken a "abcd" NMInstant apnsQ
+      tkn <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn
       liftIO $ setNtfServers a [testNtfServer2]
       NTActive <- checkNtfToken a tkn -- still works on old server
@@ -457,15 +445,15 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
         liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
         getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
         -- trigger token replace
-        tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
+        tkn2 <- registerTestToken a "xyzw" NMInstant apns
         getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
         deleteNtfToken a tkn2 -- force server switch
-        Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
+        Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apns -- ok, it's down for now
         getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
       killThread ntf
       withNtfServerOn t ntfTestPort2 $ runRight_ $ do
         liftIO $ threadDelay 1000000 -- for notification server to reconnect
-        tkn <- registerTestToken a "qwer" NMInstant apnsQ
+        tkn <- registerTestToken a "qwer" NMInstant apns
         checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
 
 testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
@@ -475,7 +463,7 @@ testRunNTFServerTests t srv =
       testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
-testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
+testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
   (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -488,11 +476,10 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     -- register notification token
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken alice tkn NMInstant
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-      atomically $ readTBQueue apnsQ
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+      getMockNotification apns tkn
     verification <- ntfData .-> "verification"
     vNonce <- C.cbNonce <$> ntfData .-> "nonce"
-    liftIO $ sendApnsResponse APNSRespOk
     verifyNtfToken alice tkn vNonce verification
     NTActive <- checkNtfToken alice tkn
     -- send message
@@ -500,7 +487,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     -- notification
-    (nonce, message) <- messageNotification apnsQ
+    (nonce, message) <- messageNotification apns tkn
     pure (bobId, aliceId, nonce, message)
 
   -- alice client already has subscription for the connection
@@ -533,65 +520,64 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     -- no notifications should follow
-    noNotification apnsQ
+    noNotification alice apns
   where
     msgId = subtract baseId
 
 testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
-testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob =
+testNotificationSubscriptionNewConnection apns baseId alice bob =
   runRight_ $ do
     -- alice registers notification token
-    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
+    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
     -- bob registers notification token
-    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ
+    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
     -- establish connection
     liftIO $ threadDelay 50000
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     liftIO $ threadDelay 1000000
     (aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ threadDelay 750000
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    void $ messageNotificationData bob apnsQ
+    void $ messageNotificationData bob apns
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    when (baseId == 3) $ void $ messageNotificationData alice apnsQ
+    when (baseId == 3) $ void $ messageNotificationData alice apns
     get alice ##> ("", bobId, CON)
-    when (baseId == 3) $ void $ messageNotificationData bob apnsQ
+    when (baseId == 3) $ void $ messageNotificationData bob apns
     get bob ##> ("", aliceId, CON)
     -- bob sends message
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
-    void $ messageNotificationData bob apnsQ
+    void $ messageNotificationData bob apns
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
     ackMessage bob aliceId (baseId + 2) Nothing
     -- no unexpected notifications should follow
-    noNotification apnsQ
+    noNotifications apns
   where
     msgId = subtract baseId
 
-registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
-registerTestToken a token mode apnsQ = do
+registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken
+registerTestToken a token mode apns = do
   let tkn = DeviceToken PPApnsTest token
   NTRegistered <- registerNtfToken a tkn mode
-  Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-    timeout 1000000 . atomically $ readTBQueue apnsQ
+  Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
+    timeout 1000000 $ getMockNotification apns tkn
   verification' <- ntfData' .-> "verification"
   nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
-  liftIO $ sendApnsResponse' APNSRespOk
   verifyNtfToken a tkn nonce' verification'
   NTActive <- checkNtfToken a tkn
   pure tkn
 
-testChangeNotificationsMode :: APNSMockServer -> IO ()
-testChangeNotificationsMode APNSMockServer {apnsQ} =
+testChangeNotificationsMode :: HasCallStack => APNSMockServer -> IO ()
+testChangeNotificationsMode apns =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -603,12 +589,12 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token, set mode to NMInstant
-    tkn <- registerTestToken alice "abcd" NMInstant apnsQ
+    tkn <- registerTestToken alice "abcd" NMInstant apns
     -- send message, receive notification
     liftIO $ threadDelay 500000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     -- set mode to NMPeriodic
@@ -617,7 +603,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
     liftIO $ threadDelay 750000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
-    noNotification apnsQ
+    noNotification alice apns
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 2) Nothing
     -- set mode to NMInstant
@@ -626,7 +612,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
     liftIO $ threadDelay 500000
     3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 3) Nothing
     -- turn off notifications
@@ -635,26 +621,26 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
     liftIO $ threadDelay 500000
     4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
-    noNotification apnsQ
+    noNotifications apns
     get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 4) Nothing
     -- turn on notifications, set mode to NMInstant
-    void $ registerTestToken alice "abcd" NMInstant apnsQ
+    void $ registerTestToken alice "abcd" NMInstant apns
     -- send message, receive notification
     liftIO $ threadDelay 500000
     5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
     get bob ##> ("", aliceId, SENT $ baseId + 5)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 5) Nothing
     -- no notifications should follow
-    noNotification apnsQ
+    noNotification alice apns
   where
     baseId = 1
     msgId = subtract baseId
 
 testChangeToken :: APNSMockServer -> IO ()
-testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
+testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
   (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -666,12 +652,12 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token, set mode to NMInstant
-    void $ registerTestToken alice "abcd" NMInstant apnsQ
+    void $ registerTestToken alice "abcd" NMInstant apns
     -- send message, receive notification
     liftIO $ threadDelay 500000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     pure (aliceId, bobId)
@@ -679,53 +665,66 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t
   withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do
     subscribeConnection alice1 bobId
     -- change notification token
-    void $ registerTestToken alice1 "bcde" NMInstant apnsQ
+    void $ registerTestToken alice1 "bcde" NMInstant apns
     -- send message, receive notification
     liftIO $ threadDelay 500000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
-    void $ messageNotificationData alice1 apnsQ
+    void $ messageNotificationData alice1 apns
     get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
     ackMessage alice1 bobId (baseId + 2) Nothing
     -- no notifications should follow
-    noNotification apnsQ
+    noNotification alice1 apns
   where
     baseId = 1
     msgId = subtract baseId
 
 testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
-testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
-  (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
-    (aliceId, bobId) <- makeConnection alice bob
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 250000
-    2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
-    get bob ##> ("", aliceId, SENT 2)
-    void $ messageNotificationData alice apnsQ
-    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId 2 Nothing
-    liftIO $ killThread threadId
-    pure (aliceId, bobId)
+testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
+      (aliceId, bobId) <- makeConnection alice bob
+      _ <- registerTestToken alice "abcd" NMInstant apns
+      liftIO $ threadDelay 250000
+      2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+      get bob ##> ("", aliceId, SENT 2)
+      void $ messageNotificationData alice apns
+      get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+      ackMessage alice bobId 2 Nothing
+      liftIO $ killThread threadId
+      pure (aliceId, bobId)
 
-  liftIO $ threadDelay 250000
-
-  withNtfServerStoreLog t $ \threadId -> runRight_ $ do
     liftIO $ threadDelay 250000
-    3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
-    get bob ##> ("", aliceId, SENT 3)
-    void $ messageNotificationData alice apnsQ
-    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-    liftIO $ killThread threadId
+
+    withNtfServerStoreLog t $ \threadId -> runRight_ $ do
+      liftIO $ threadDelay 250000
+      3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+      get bob ##> ("", aliceId, SENT 3)
+      void $ messageNotificationData alice apns
+      get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+      ackMessage alice bobId 3 Nothing
+      liftIO $ killThread threadId
+
+    runRight_ $ do
+      4 <- sendMessage bob aliceId (SMP.MsgFlags True) "message 4"
+      get bob ##> ("", aliceId, SENT 4)
+      get alice =##> \case ("", c, Msg "message 4") -> c == bobId; _ -> False
+      ackMessage alice bobId 4 Nothing
+      noNotifications apns
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ ->
+    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+      void $ messageNotificationData alice apns
 
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
-testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
+testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do
   (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
+    _ <- registerTestToken alice "abcd" NMInstant apns
     liftIO $ threadDelay 250000
     2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT 2)
-    void $ messageNotificationData alice apnsQ
+    void $ messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId 2 Nothing
     liftIO $ killThread threadId
@@ -741,22 +740,22 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic
     liftIO $ threadDelay 1000000
     3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT 3)
-    _ <- messageNotificationData alice apnsQ
+    _ <- messageNotificationData alice apns
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
 
 testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
-testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
+testNotificationsSMPRestartBatch n t apns =
   withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     threadDelay 1000000
     conns <- runServers $ do
       conns <- replicateM (n :: Int) $ makeConnection a b
-      _ <- registerTestToken a "abcd" NMInstant apnsQ
+      _ <- registerTestToken a "abcd" NMInstant apns
       liftIO $ threadDelay 5000000
       forM_ conns $ \(aliceId, bobId) -> do
         msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
         get b ##> ("", aliceId, SENT msgId)
-        void $ messageNotificationData a apnsQ
+        void $ messageNotificationData a apns
         get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
         ackMessage a bobId msgId Nothing
       pure conns
@@ -780,7 +779,7 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
       forM_ conns $ \(aliceId, bobId) -> do
         msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
         get b ##> ("", aliceId, SENT msgId)
-        _ <- messageNotificationData a apnsQ
+        _ <- messageNotificationData a apns
         get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
   where
     runServers :: ExceptT AgentErrorType IO a -> IO a
@@ -792,16 +791,16 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
         pure res
 
 testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
-testSwitchNotifications servers APNSMockServer {apnsQ} =
+testSwitchNotifications servers apns =
   withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetings a bId b aId
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
+    _ <- registerTestToken a "abcd" NMInstant apns
     liftIO $ threadDelay 250000
     let testMessage msg = do
           msgId <- sendMessage b aId (SMP.MsgFlags True) msg
           get b ##> ("", aId, SENT msgId)
-          void $ messageNotificationData a apnsQ
+          void $ messageNotificationData a apns
           get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
           ackMessage a bId msgId Nothing
     testMessage "hello"
@@ -811,74 +810,80 @@ testSwitchNotifications servers APNSMockServer {apnsQ} =
     testMessage "hello again"
 
 testNotificationsOldToken :: APNSMockServer -> IO ()
-testNotificationsOldToken APNSMockServer {apnsQ} =
+testNotificationsOldToken apns =
   withAgentClients3 $ \a b c -> runRight_ $ do
     (abId, baId) <- makeConnection a b
-    let testMessageAB = testMessage_ apnsQ a abId b baId
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
+    let testMessageAB = testMessage_ apns a abId b baId
+    _ <- registerTestToken a "abcd" NMInstant apns
     liftIO $ threadDelay 250000
     testMessageAB "hello"
     -- change server
     liftIO $ setNtfServers a [testNtfServer2] -- server 2 isn't running now, don't use
     -- replacing token keeps server
-    _ <- registerTestToken a "xyzw" NMInstant apnsQ
+    _ <- registerTestToken a "xyzw" NMInstant apns
     getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
     testMessageAB "still there"
     -- new connections keep server
     (acId, caId) <- makeConnection a c
-    let testMessageAC = testMessage_ apnsQ a acId c caId
+    let testMessageAC = testMessage_ apns a acId c caId
     testMessageAC "greetings"
 
 testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
-testNotificationsNewToken APNSMockServer {apnsQ} oldNtf =
+testNotificationsNewToken apns oldNtf =
   withAgentClients3 $ \a b c -> runRight_ $ do
     (abId, baId) <- makeConnection a b
-    let testMessageAB = testMessage_ apnsQ a abId b baId
-    tkn <- registerTestToken a "abcd" NMInstant apnsQ
+    let testMessageAB = testMessage_ apns a abId b baId
+    tkn <- registerTestToken a "abcd" NMInstant apns
     getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
     liftIO $ threadDelay 250000
     testMessageAB "hello"
     -- switch
     liftIO $ setNtfServers a [testNtfServer2]
     deleteNtfToken a tkn
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
+    _ <- registerTestToken a "abcd" NMInstant apns
     getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort2
     liftIO $ threadDelay 250000
     liftIO $ killThread oldNtf
     -- -- back to work
     testMessageAB "hello again"
     (acId, caId) <- makeConnection a c
-    let testMessageAC = testMessage_ apnsQ a acId c caId
+    let testMessageAC = testMessage_ apns a acId c caId
     testMessageAC "greetings"
 
-testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
-testMessage_ apnsQ a aId b bId msg = do
+testMessage_ :: HasCallStack => APNSMockServer -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
+testMessage_ apns a aId b bId msg = do
   msgId <- sendMessage b aId (SMP.MsgFlags True) msg
   get b ##> ("", aId, SENT msgId)
-  void $ messageNotificationData a apnsQ
+  void $ messageNotificationData a apns
   get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
   ackMessage a bId msgId Nothing
 
-messageNotification :: HasCallStack => TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
-messageNotification apnsQ = do
-  1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
+messageNotification apns tkn = do
+  500000 `timeout` getMockNotification apns tkn >>= \case
     Nothing -> error "no notification"
-    Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
+    Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       message <- ntfData .-> "message"
-      liftIO $ sendApnsResponse APNSRespOk
       pure (nonce, message)
     _ -> error "bad notification"
 
-messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
-messageNotificationData c apnsQ = do
-  (nonce, message) <- messageNotification apnsQ
-  NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
+messageNotificationData :: HasCallStack => AgentClient -> APNSMockServer -> ExceptT AgentErrorType IO PNMessageData
+messageNotificationData c apns = do
+  NtfToken {deviceToken, ntfDhSecret = Just dhSecret} <- getNtfTokenData c
+  (nonce, message) <- messageNotification apns deviceToken
   Right pnMsgs <- liftEither . first INTERNAL $ Right . parseAll pnMessagesP =<< first show (C.cbDecrypt dhSecret nonce message)
   pure $ L.last pnMsgs
 
-noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
-noNotification apnsQ = do
-  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+noNotification :: AgentClient -> APNSMockServer -> ExceptT AgentErrorType IO ()
+noNotification c apns = do
+  NtfToken {deviceToken} <- getNtfTokenData c
+  500000 `timeout` getMockNotification apns deviceToken >>= \case
+    Nothing -> pure ()
+    _ -> error "unexpected notification"
+
+noNotifications :: APNSMockServer -> ExceptT AgentErrorType IO ()
+noNotifications apns = do
+  500000 `timeout` getAnyMockNotification apns >>= \case
     Nothing -> pure ()
     _ -> error "unexpected notification"

tests/AgentTests/SQLiteTests.hs

@@ -13,7 +13,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
-module AgentTests.SQLiteTests (storeTests) where
+module AgentTests.SQLiteTests where
 
 import AgentTests.EqInstances ()
 import Control.Concurrent.Async (concurrently_)

tests/AgentTests/SchemaDump.hs

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

tests/CLITests.hs

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

tests/CoreTests/BatchingTests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -14,11 +15,13 @@ import Crypto.Random (ChaChaDRG)
 import qualified Data.ByteString as B
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.List.NonEmpty as L
+import Data.Time.Clock.System (SystemTime, getSystemTime)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import qualified Data.X509.File as XF
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
 import Test.Hspec
@@ -26,42 +29,43 @@ import Test.Hspec
 batchingTests :: Spec
 batchingTests = do
   describe "batchTransmissions" $ do
-    describe "SMP v6 (current)" $ do
-      it "should batch with 107 subscriptions per batch" testBatchSubscriptions
+    describe "SMP v6 (previous)" $ do
+      it "should batch with 106 subscriptions per batch" testBatchSubscriptionsV6
+      it "should break on message that does not fit" testBatchWithMessageV6
+      it "should break on large message" testBatchWithLargeMessageV6
+    describe "SMP current" $ do
+      it "should batch with 136 subscriptions per batch" testBatchSubscriptions
       it "should break on message that does not fit" testBatchWithMessage
       it "should break on large message" testBatchWithLargeMessage
-    describe "v7 (next)" $ do
-      it "should batch with 136 subscriptions per batch" testBatchSubscriptionsV7
-      it "should break on message that does not fit" testBatchWithMessageV7
-      it "should break on large message" testBatchWithLargeMessageV7
   describe "batchTransmissions'" $ do
-    describe "SMP v6 (current)" $ do
-      it "should batch with 107 subscriptions per batch" testClientBatchSubscriptions
+    describe "SMP v6 (previous)" $ do
+      it "should batch with 106 subscriptions per batch" testClientBatchSubscriptionsV6
+      it "should break on message that does not fit" testClientBatchWithMessageV6
+      it "should break on large message" testClientBatchWithLargeMessageV6
+    describe "SMP current" $ do
+      it "should batch with 136 subscriptions per batch" testClientBatchSubscriptions
+      it "should batch with 255 ENDs per batch" testClientBatchENDs
+      it "should batch with 80 NMSGs per batch" testClientBatchNMSGs
       it "should break on message that does not fit" testClientBatchWithMessage
       it "should break on large message" testClientBatchWithLargeMessage
-    describe "v7 (next)" $ do
-      it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7
-      it "should batch with N ENDs per batch" testClientBatchENDs
-      it "should break on message that does not fit" testClientBatchWithMessageV7
-      it "should break on large message" testClientBatchWithLargeMessageV7
 
-testBatchSubscriptions :: IO ()
-testBatchSubscriptions = do
+testBatchSubscriptionsV6 :: IO ()
+testBatchSubscriptionsV6 = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs <- replicateM 250 $ randomSUB sessId
+  subs <- replicateM 250 $ randomSUBv6 sessId
   let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 250
   let batches = batchTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (36, 107, 107)
+  (n1, n2, n3) `shouldBe` (38, 106, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
-testBatchSubscriptionsV7 :: IO ()
-testBatchSubscriptionsV7 = do
+testBatchSubscriptions :: IO ()
+testBatchSubscriptions = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs <- replicateM 300 $ randomSUBv7 sessId
+  subs <- replicateM 300 $ randomSUB sessId
   let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 300
@@ -71,6 +75,22 @@ testBatchSubscriptionsV7 = do
   (n1, n2, n3) `shouldBe` (28, 136, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
+testBatchWithMessageV6 :: IO ()
+testBatchWithMessageV6 = do
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  subs1 <- replicateM 60 $ randomSUBv6 sessId
+  send <- randomSENDv6 sessId 8000
+  subs2 <- replicateM 40 $ randomSUBv6 sessId
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` True
+  length batches1 `shouldBe` 101
+  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 2
+  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
+  (n1, n2) `shouldBe` (47, 54)
+  all lenOk [s1, s2] `shouldBe` True
+
 testBatchWithMessage :: IO ()
 testBatchWithMessage = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
@@ -84,31 +104,15 @@ testBatchWithMessage = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
-  (n1, n2) `shouldBe` (47, 54)
-  all lenOk [s1, s2] `shouldBe` True
-
-testBatchWithMessageV7 :: IO ()
-testBatchWithMessageV7 = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs1 <- replicateM 60 $ randomSUBv7 sessId
-  send <- randomSENDv7 sessId 8000
-  subs2 <- replicateM 40 $ randomSUBv7 sessId
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
-  all lenOk1 batches1 `shouldBe` True
-  length batches1 `shouldBe` 101
-  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
-  length batches `shouldBe` 2
-  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
   (n1, n2) `shouldBe` (32, 69)
   all lenOk [s1, s2] `shouldBe` True
 
-testBatchWithLargeMessage :: IO ()
-testBatchWithLargeMessage = do
+testBatchWithLargeMessageV6 :: IO ()
+testBatchWithLargeMessageV6 = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs1 <- replicateM 50 $ randomSUB sessId
-  send <- randomSEND sessId 17000
-  subs2 <- replicateM 150 $ randomSUB sessId
+  subs1 <- replicateM 50 $ randomSUBv6 sessId
+  send <- randomSENDv6 sessId 17000
+  subs2 <- replicateM 150 $ randomSUBv6 sessId
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
@@ -119,15 +123,15 @@ testBatchWithLargeMessage = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 43, 107)
+  (n1, n2, n3) `shouldBe` (50, 44, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
-testBatchWithLargeMessageV7 :: IO ()
-testBatchWithLargeMessageV7 = do
+testBatchWithLargeMessage :: IO ()
+testBatchWithLargeMessage = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs1 <- replicateM 60 $ randomSUBv7 sessId
-  send <- randomSENDv7 sessId 17000
-  subs2 <- replicateM 150 $ randomSUBv7 sessId
+  subs1 <- replicateM 60 $ randomSUB sessId
+  send <- randomSEND sessId 17000
+  subs2 <- replicateM 150 $ randomSUB sessId
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
@@ -141,23 +145,23 @@ testBatchWithLargeMessageV7 = do
   (n1, n2, n3) `shouldBe` (60, 14, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
-testClientBatchSubscriptions :: IO ()
-testClientBatchSubscriptions = do
-  client <- testClientStub
-  subs <- replicateM 250 $ randomSUBCmd client
+testClientBatchSubscriptionsV6 :: IO ()
+testClientBatchSubscriptionsV6 = do
+  client <- testClientStubV6
+  subs <- replicateM 250 $ randomSUBCmdV6 client
   let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (36, 107, 107)
-  (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107)
+  (n1, n2, n3) `shouldBe` (38, 106, 106)
+  (length rs1, length rs2, length rs3) `shouldBe` (38, 106, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
-testClientBatchSubscriptionsV7 :: IO ()
-testClientBatchSubscriptionsV7 = do
-  client <- clientStubV7
-  subs <- replicateM 300 $ randomSUBCmdV7 client
+testClientBatchSubscriptions :: IO ()
+testClientBatchSubscriptions = do
+  client <- testClientStub
+  subs <- replicateM 300 $ randomSUBCmd client
   let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
@@ -169,7 +173,7 @@ testClientBatchSubscriptionsV7 = do
 
 testClientBatchENDs :: IO ()
 testClientBatchENDs = do
-  client <- clientStubV7
+  client <- testClientStub
   ends <- replicateM 300 randomENDCmd
   let ends' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ends
       batches1 = batchTransmissions False smpBlockSize $ L.fromList ends'
@@ -181,6 +185,38 @@ testClientBatchENDs = do
   (length rs1, length rs2) `shouldBe` (45, 255)
   all lenOk [s1, s2] `shouldBe` True
 
+testClientBatchNMSGs :: IO ()
+testClientBatchNMSGs = do
+  client <- testClientStub
+  ts <- getSystemTime
+  ntfs <- replicateM 200 $ randomNMSGCmd ts
+  let ntfs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ntfs
+      batches1 = batchTransmissions False smpBlockSize $ L.fromList ntfs'
+  all lenOk1 batches1 `shouldBe` True
+  let batches = batchTransmissions True smpBlockSize $ L.fromList ntfs'
+  length batches `shouldBe` 3
+  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (40, 80, 80)
+  (length rs1, length rs2, length rs3) `shouldBe` (40, 80, 80)
+  all lenOk [s1, s2, s3] `shouldBe` True
+
+testClientBatchWithMessageV6 :: IO ()
+testClientBatchWithMessageV6 = do
+  client <- testClientStubV6
+  subs1 <- replicateM 60 $ randomSUBCmdV6 client
+  send <- randomSENDCmdV6 client 8000
+  subs2 <- replicateM 40 $ randomSUBCmdV6 client
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` True
+  length batches1 `shouldBe` 101
+  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 2
+  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
+  (n1, n2) `shouldBe` (47, 54)
+  (length rs1, length rs2) `shouldBe` (47, 54)
+  all lenOk [s1, s2] `shouldBe` True
+
 testClientBatchWithMessage :: IO ()
 testClientBatchWithMessage = do
   client <- testClientStub
@@ -194,33 +230,16 @@ testClientBatchWithMessage = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
-  (n1, n2) `shouldBe` (47, 54)
-  (length rs1, length rs2) `shouldBe` (47, 54)
-  all lenOk [s1, s2] `shouldBe` True
-
-testClientBatchWithMessageV7 :: IO ()
-testClientBatchWithMessageV7 = do
-  client <- clientStubV7
-  subs1 <- replicateM 60 $ randomSUBCmdV7 client
-  send <- randomSENDCmdV7 client 8000
-  subs2 <- replicateM 40 $ randomSUBCmdV7 client
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
-  all lenOk1 batches1 `shouldBe` True
-  length batches1 `shouldBe` 101
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
-  length batches `shouldBe` 2
-  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
   (n1, n2) `shouldBe` (32, 69)
   (length rs1, length rs2) `shouldBe` (32, 69)
   all lenOk [s1, s2] `shouldBe` True
 
-testClientBatchWithLargeMessage :: IO ()
-testClientBatchWithLargeMessage = do
-  client <- testClientStub
-  subs1 <- replicateM 50 $ randomSUBCmd client
-  send <- randomSENDCmd client 17000
-  subs2 <- replicateM 150 $ randomSUBCmd client
+testClientBatchWithLargeMessageV6 :: IO ()
+testClientBatchWithLargeMessageV6 = do
+  client <- testClientStubV6
+  subs1 <- replicateM 50 $ randomSUBCmdV6 client
+  send <- randomSENDCmdV6 client 17000
+  subs2 <- replicateM 150 $ randomSUBCmdV6 client
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
@@ -232,24 +251,24 @@ testClientBatchWithLargeMessage = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 43, 107)
-  (length rs1, length rs2, length rs3) `shouldBe` (50, 43, 107)
+  (n1, n2, n3) `shouldBe` (50, 44, 106)
+  (length rs1, length rs2, length rs3) `shouldBe` (50, 44, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
   let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
   length batches' `shouldBe` 3
   [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (93, 107)
-  (length rs1', length rs2') `shouldBe` (93, 107)
+  (n1', n2') `shouldBe` (94, 106)
+  (length rs1', length rs2') `shouldBe` (94, 106)
   all lenOk [s1', s2'] `shouldBe` True
 
-testClientBatchWithLargeMessageV7 :: IO ()
-testClientBatchWithLargeMessageV7 = do
-  client <- clientStubV7
-  subs1 <- replicateM 60 $ randomSUBCmdV7 client
-  send <- randomSENDCmdV7 client 17000
-  subs2 <- replicateM 150 $ randomSUBCmdV7 client
+testClientBatchWithLargeMessage :: IO ()
+testClientBatchWithLargeMessage = do
+  client <- testClientStub
+  subs1 <- replicateM 60 $ randomSUBCmd client
+  send <- randomSENDCmd client 17000
+  subs2 <- replicateM 150 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
@@ -273,25 +292,25 @@ testClientBatchWithLargeMessageV7 = do
   (length rs1', length rs2') `shouldBe` (74, 136)
   all lenOk [s1', s2'] `shouldBe` True
 
-testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
-testClientStub = do
+testClientStubV6 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
+testClientStubV6 = do
   g <- C.newRandom
   sessId <- atomically $ C.randomBytes 32 g
   smpClientStub g sessId subModeSMPVersion Nothing
 
-clientStubV7 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
-clientStubV7 = do
+testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
+testClientStub = do
   g <- C.newRandom
   sessId <- atomically $ C.randomBytes 32 g
   (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
-  thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey
-  smpClientStub g sessId authCmdsSMPVersion thAuth_
+  thAuth_ <- testTHandleAuth currentClientSMPRelayVersion g rKey
+  smpClientStub g sessId currentClientSMPRelayVersion thAuth_
+
+randomSUBv6 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUBv6 = randomSUB_ C.SEd25519 subModeSMPVersion
 
 randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
-randomSUB = randomSUB_ C.SEd25519 subModeSMPVersion
-
-randomSUBv7 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
-randomSUBv7 = randomSUB_ C.SEd25519 authCmdsSMPVersion
+randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion
 
 randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
 randomSUB_ a v sessId = do
@@ -304,11 +323,11 @@ randomSUB_ a v sessId = do
       TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB)
   pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth
 
-randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
-randomSUBCmd = randomSUBCmd_ C.SEd25519
+randomSUBCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
+randomSUBCmdV6 = randomSUBCmd_ C.SEd25519
 
-randomSUBCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
-randomSUBCmdV7 = randomSUBCmd_ C.SEd25519 -- same as v6
+randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
+randomSUBCmd = randomSUBCmd_ C.SEd25519 -- same as v6
 
 randomSUBCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
 randomSUBCmd_ a c = do
@@ -323,11 +342,22 @@ randomENDCmd = do
   rId <- atomically $ C.randomBytes 24 g
   pure (CorrId "", EntityId rId, END)
 
-randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
-randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion
+randomNMSGCmd :: SystemTime -> IO (Transmission BrokerMsg)
+randomNMSGCmd ts = do
+  g <- C.newRandom
+  nId <- atomically $ C.randomBytes 24 g
+  msgId <- atomically $ C.randomBytes 24 g
+  (k, pk) <- atomically $ C.generateKeyPair g
+  nonce <- atomically $ C.randomCbNonce g
+  let msgMeta = NMsgMeta {msgId, msgTs = ts}
+  Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128
+  pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta)
 
-randomSENDv7 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
-randomSENDv7 = randomSEND_ C.SX25519 authCmdsSMPVersion
+randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSENDv6 = randomSEND_ C.SEd25519 subModeSMPVersion
+
+randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSEND = randomSEND_ C.SX25519 currentClientSMPRelayVersion
 
 randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
 randomSEND_ a v sessId len = do
@@ -350,6 +380,7 @@ testTHandleParams v sessionId =
       thServerVRange = supportedServerSMPRelayVRange,
       thAuth = Nothing,
       implySessId = v >= authCmdsSMPVersion,
+      encryptBlock = Nothing,
       batch = True
     }
 
@@ -365,11 +396,11 @@ testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
     pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
   _ -> pure Nothing
 
-randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
-randomSENDCmd = randomSENDCmd_ C.SEd25519
+randomSENDCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+randomSENDCmdV6 = randomSENDCmd_ C.SEd25519
 
-randomSENDCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
-randomSENDCmdV7 = randomSENDCmd_ C.SX25519
+randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+randomSENDCmd = randomSENDCmd_ C.SX25519
 
 randomSENDCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
 randomSENDCmd_ a c len = do

tests/CoreTests/SOCKSSettings.hs

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

tests/CoreTests/StoreLogTests.hs

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

tests/NtfClient.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -14,14 +15,18 @@
 
 module NtfClient where
 
+import Control.Concurrent.STM (retry)
 import Control.Monad
 import Control.Monad.Except (runExceptT)
+import Control.Monad.IO.Class
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Map.Strict as M
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status)
@@ -33,13 +38,14 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost,
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol (NtfResponse)
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
@@ -81,11 +87,14 @@ ntfServerCfg :: NtfServerConfig
 ntfServerCfg =
   NtfServerConfig
     { transports = [],
+      controlPort = Nothing,
+      controlPortUserAuth = Nothing,
+      controlPortAdminAuth = Nothing,
       subIdBytes = 24,
       regCodeBytes = 32,
-      clientQSize = 1,
-      subQSize = 1,
-      pushQSize = 1,
+      clientQSize = 2,
+      subQSize = 2,
+      pushQSize = 2,
       smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
       apnsConfig =
         defaultAPNSPushClientConfig
@@ -124,7 +133,7 @@ ntfServerCfgVPrev =
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
 withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t, False)]}
 
-withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
+withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]}
 
 withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a
@@ -136,10 +145,10 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
         (\started -> runNtfServerBlocking started cfg)
         (pure ())
 
-withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a
+withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => IO a) -> IO a
 withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 
-withNtfServer :: ATransport -> IO a -> IO a
+withNtfServer :: HasCallStack => ATransport -> (HasCallStack => IO a) -> IO a
 withNtfServer t = withNtfServerOn t ntfTestPort
 
 runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
@@ -166,22 +175,21 @@ ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expect
 ntfTest _ test' = runNtfTest test' `shouldReturn` ()
 
 data APNSMockRequest = APNSMockRequest
-  { notification :: APNSNotification,
-    sendApnsResponse :: APNSMockResponse -> IO ()
+  { notification :: APNSNotification
   }
 
 data APNSMockResponse = APNSRespOk | APNSRespError Status Text
 
 data APNSMockServer = APNSMockServer
   { action :: Async (),
-    apnsQ :: TBQueue APNSMockRequest,
+    notifications :: TM.TMap ByteString (TBQueue APNSMockRequest),
     http2Server :: HTTP2Server
   }
 
 apnsMockServerConfig :: HTTP2ServerConfig
 apnsMockServerConfig =
   HTTP2ServerConfig
-    { qSize = 1,
+    { qSize = 2,
       http2Port = apnsTestPort,
       bufferSize = 16384,
       bodyHeadSize = 16384,
@@ -224,23 +232,36 @@ deriving instance ToJSON APNSErrorResponse
 getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
 getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
   http2Server <- getHTTP2Server config Nothing
-  apnsQ <- newTBQueueIO qSize
-  action <- async $ runAPNSMockServer apnsQ http2Server
-  pure APNSMockServer {action, apnsQ, http2Server}
+  notifications <- TM.emptyIO
+  action <- async $ runAPNSMockServer notifications http2Server
+  pure APNSMockServer {action, notifications, http2Server}
   where
-    runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do
-      HTTP2Request {reqBody = HTTP2Body {bodyHead}, sendResponse} <- atomically $ readTBQueue reqQ
+    runAPNSMockServer notifications HTTP2Server {reqQ} = forever $ do
+      HTTP2Request {request, reqBody = HTTP2Body {bodyHead}, 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' bodyHead of
-        Just notification ->
-          atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
+        Just notification -> do
+          Just token <- pure $ B.stripPrefix "/3/device/" =<< H.requestPath request
+          q <- atomically $ TM.lookup token notifications >>= maybe (newTokenQueue token) pure
+          atomically $ writeTBQueue q APNSMockRequest {notification}
+          sendApnsResponse APNSRespOk
+          where
+            newTokenQueue token = newTBQueue qSize >>= \q -> TM.insert token q notifications >> pure q
         _ -> do
           putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
+getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
+getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do
+  atomically $ TM.lookup token notifications >>= maybe retry readTBQueue
+
+getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest
+getAnyMockNotification APNSMockServer {notifications} = do
+  atomically $ readTVar notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf
+
 closeAPNSMockServer :: APNSMockServer -> IO ()
 closeAPNSMockServer APNSMockServer {action, http2Server} = do
   closeHTTP2Server http2Server

tests/NtfServerTests.hs

@@ -104,16 +104,15 @@ testNotificationSubscription (ATransport t) =
     (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
     let tkn = DeviceToken PPApnsTest "abcd"
-    withAPNSMockServer $ \APNSMockServer {apnsQ} ->
+    withAPNSMockServer $ \apns ->
       smpTest2 t $ \rh sh ->
         ntfTest t $ \nh -> do
           -- create queue
           (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
           -- register and verify token
           RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
-          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <-
-            atomically $ readTBQueue apnsQ
-          send APNSRespOk
+          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+            getMockNotification apns tkn
           let dhSecret = C.dh' ntfDh dhPriv
               Right verification = ntfData .-> "verification"
               Right nonce = C.cbNonce <$> ntfData .-> "nonce"
@@ -131,7 +130,7 @@ testNotificationSubscription (ATransport t) =
           threadDelay 50000
           Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello")
           -- receive notification
-          APNSMockRequest {notification, sendApnsResponse = send'} <- atomically $ readTBQueue apnsQ
+          APNSMockRequest {notification} <- getMockNotification apns tkn
           let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification
               Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
               Right message = ntfData' .-> "message"
@@ -142,7 +141,6 @@ testNotificationSubscription (ATransport t) =
               Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
           smpServer `shouldBe` srv
           notifierId `shouldBe` nId
-          send' APNSRespOk
           -- receive message
           Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
           Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
@@ -154,9 +152,8 @@ testNotificationSubscription (ATransport t) =
           let tkn' = DeviceToken PPApnsTest "efgh"
           RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
           tId `shouldBe` tId'
-          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}, sendApnsResponse = send2} <-
-            atomically $ readTBQueue apnsQ
-          send2 APNSRespOk
+          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <-
+            getMockNotification apns tkn'
           let Right verification2 = ntfData2 .-> "verification"
               Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce"
               Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2
@@ -164,7 +161,7 @@ testNotificationSubscription (ATransport t) =
           RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK)
           -- send message
           Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2")
-          APNSMockRequest {notification = notification3, sendApnsResponse = send3} <- atomically $ readTBQueue apnsQ
+          APNSMockRequest {notification = notification3} <- getMockNotification apns tkn'
           let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3
               Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
               Right message3 = ntfData3 .-> "message"
@@ -173,4 +170,3 @@ testNotificationSubscription (ATransport t) =
               APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId
-          send3 APNSRespOk

tests/SMPClient.hs

@@ -62,6 +62,12 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 testStoreMsgsFile2 :: FilePath
 testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2"
 
+testStoreNtfsFile :: FilePath
+testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log"
+
+testStoreNtfsFile2 :: FilePath
+testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2"
+
 testServerStatsBackupFile :: FilePath
 testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
@@ -104,17 +110,20 @@ cfg =
       msgIdBytes = 24,
       storeLogFile = Nothing,
       storeMsgsFile = Nothing,
+      storeNtfsFile = Nothing,
       allowNewQueues = True,
       newQueueBasicAuth = Nothing,
       controlPortUserAuth = Nothing,
       controlPortAdminAuth = Nothing,
       messageExpiration = Just defaultMessageExpiration,
+      notificationExpiration = defaultNtfExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/smp-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
       pendingENDInterval = 500000,
+      ntfDeliveryInterval = 200000,
       smpCredentials =
         ServerCredentials
           { caCertificateFile = Just "tests/fixtures/ca.crt",
@@ -159,7 +168,15 @@ proxyVRangeV8 :: VersionRangeSMP
 proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
 
 withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
+withSmpServerStoreMsgLogOn t =
+  withSmpServerConfigOn
+    t
+    cfg
+      { storeLogFile = Just testStoreLogFile,
+        storeMsgsFile = Just testStoreMsgsFile,
+        storeNtfsFile = Just testStoreNtfsFile,
+        serverStatsBackupFile = Just testServerStatsBackupFile
+      }
 
 withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}

tests/SMPProxyTests.hs

@@ -35,7 +35,7 @@ import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
-import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, maxMessageLength, noMsgFlags)
+import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport
@@ -63,7 +63,7 @@ smpProxyTests = do
     let srv1 = SMPServer testHost testPort testKeyHash
         srv2 = SMPServer testHost testPort2 testKeyHash
     describe "client API" $ do
-      let maxLen = maxMessageLength sendingProxySMPVersion
+      let maxLen = maxMessageLength encryptedBlockSMPVersion
       describe "one server" $ do
         it "deliver via proxy" . oneServer $ do
           deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"
@@ -210,7 +210,8 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
       (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -265,7 +266,8 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
       (bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      (aliceId, sqSecured) <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      sqSecured <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       confId <-
         get alice >>= \case
@@ -315,7 +317,8 @@ agentViaProxyVersionError =
     Left (A.BROKER _ (TRANSPORT TEVersion)) <-
       withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
         (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-        A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+        aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+        A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     pure ()
   where
     servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs}
@@ -334,7 +337,8 @@ agentViaProxyRetryOffline = do
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
           (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-          (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+          aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+          sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
           liftIO $ sqSecured `shouldBe` True
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
           liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -375,11 +379,11 @@ agentViaProxyRetryOffline = do
             ackMessage alice bobId (baseId + 4) Nothing
   where
     withServer :: (ThreadId -> IO a) -> IO a
-    withServer = withServer_ testStoreLogFile testStoreMsgsFile testPort
+    withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort
     withServer2 :: (ThreadId -> IO a) -> IO a
-    withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testPort2
-    withServer_ storeLog storeMsgs port =
-      withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port
+    withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2
+    withServer_ storeLog storeMsgs storeNtfs port =
+      withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} port
     a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
     a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
     aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval}

tests/ServerTests.hs

@@ -51,6 +51,9 @@ serverTests t@(ATransport t') = do
   describe "SMP syntax" $ syntaxTests t
   describe "SMP queues" $ do
     describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
+    describe "NEW and SKEY commands" $ do
+      testCreateSndSecure t
+      testSndSecureProhibited t
     describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
     describe "Stress test" $ stressTest t
     describe "allowNewQueues setting" $ testAllowNewQueues t'
@@ -193,6 +196,68 @@ testCreateSecure (ATransport t) =
       Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
       pure ()
 
+testCreateSndSecure :: ATransport -> Spec
+testCreateSndSecure (ATransport t) =
+  it "should create (NEW) and secure (SKEY) queue by sender" $
+    smpTest2 t $ \r s -> do
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
+      (rId1, NoEntity) #== "creates queue"
+
+      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+      Resp "bcda" _ err2 <- sendRecv s (sampleSig, "bcda", sId, SKEY sPub)
+      (err2, ERR AUTH) #== "rejects SKEY with wrong signature"
+
+      Resp "cdab" _ err3 <- signSendRecv s sKey ("cdab", rId, SKEY sPub)
+      (err3, ERR AUTH) #== "rejects SKEY with recipients's ID"
+
+      Resp "dabc" sId2 OK <- signSendRecv s sKey ("dabc", sId, SKEY sPub)
+      (sId2, sId) #== "secures queue, same queue ID in response"
+
+      (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+      Resp "abcd" _ err4 <- signSendRecv s sKey ("abcd", sId, SKEY sPub')
+      (err4, ERR AUTH) #== "rejects if secured with different key"
+      Resp "abcd" _ OK <- signSendRecv s sKey ("abcd", sId, SKEY sPub)
+
+      Resp "bcda" _ ok3 <- signSendRecv s sKey ("bcda", sId, _SEND "hello")
+      (ok3, OK) #== "accepts signed SEND"
+
+      Resp "" _ (Msg mId2 msg2) <- tGet1 r
+      (dec mId2 msg2, Right "hello") #== "delivers message"
+
+      Resp "cdab" _ ok5 <- signSendRecv r rKey ("cdab", rId, ACK mId2)
+      (ok5, OK) #== "replies OK when message acknowledged"
+
+      Resp "dabc" _ err5 <- sendRecv s ("", "dabc", sId, _SEND "hello")
+      (err5, ERR AUTH) #== "rejects unsigned SEND"
+
+      let maxAllowedMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion) '-'
+      Resp "bcda" _ OK <- signSendRecv s sKey ("bcda", sId, _SEND maxAllowedMessage)
+      Resp "" _ (Msg mId3 msg3) <- tGet1 r
+      (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
+
+      let biggerMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion + 1) '-'
+      Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
+      pure ()
+
+testSndSecureProhibited :: ATransport -> Spec
+testSndSecureProhibited (ATransport t) =
+  it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $
+    smpTest2 t $ \r s -> do
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+      (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+      (rId1, NoEntity) #== "creates queue"
+
+      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+      Resp "dabc" sId2 err <- signSendRecv s sKey ("dabc", sId, SKEY sPub)
+      (sId2, sId) #== "secures queue, same queue ID in response"
+      (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command"
+
 testCreateDelete :: ATransport -> Spec
 testCreateDelete (ATransport t) =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
@@ -615,7 +680,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 2
     logSize testStoreMsgsFile `shouldReturn` 5
-    logSize testServerStatsBackupFile `shouldReturn` 72
+    logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
 
@@ -633,7 +698,7 @@ testRestoreMessages at@(ATransport t) =
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
     logSize testStoreMsgsFile `shouldReturn` 3
-    logSize testServerStatsBackupFile `shouldReturn` 72
+    logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
@@ -652,7 +717,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
-    logSize testServerStatsBackupFile `shouldReturn` 72
+    logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
 

tests/Test.hs

@@ -13,6 +13,7 @@ import CoreTests.CryptoTests
 import CoreTests.EncodingTests
 import CoreTests.RetryIntervalTests
 import CoreTests.SOCKSSettings
+import CoreTests.StoreLogTests
 import CoreTests.TRcvQueuesTests
 import CoreTests.UtilTests
 import CoreTests.VersionRangeTests
@@ -54,6 +55,7 @@ main = do
           describe "Encrypted files tests" cryptoFileTests
           describe "Retry interval tests" retryIntervalTests
           describe "SOCKS settings tests" socksSettingsTests
+          describe "Store log tests" storeLogTests
           describe "TRcvQueues tests" tRcvQueuesTests
           describe "Util tests" utilTests
         describe "SMP server via TLS" $ serverTests (transport @TLS)