trying to use semaphores

* log weekly and monthly active queues

* update

CHANGELOG.md

@@ -1,3 +1,26 @@
+# 2.3.0
+
+SMP server:
+
+- Save and restore undelivered messages, to avoid losing them. To save messages the server has to be stopped with SIGINT signal, if it is stopped with SIGTERM undelivered messages would not be saved.
+
+# 2.2.0
+
+SMP server:
+
+- Fix sockets/threads/memory leak
+
+SMP agent:
+
+- Support stopping and resuming agent with `disconnectAgentClient` / `resumeAgentClient`
+
+# 2.1.1
+
+SMP server:
+
+- gracefully close sockets on client disconnection
+- CLI warning when deleting server configuration
+
 # 2.1.0
 
 SMP server:

README.md

@@ -35,6 +35,8 @@ SMP server uses in-memory persistence with an optional append-only log of create
 
 To enable store log, initialize server using `smp-server -l` command, or modify `smp-server.ini` created during initialization (uncomment `enable: on` option in the store log section). Use `smp-server --help` for other usage tips.
 
+Starting from version 2.3.0, when store log is enabled, the server would also enable saving undelivered messages on exit and restoring them on start. This can be disabled via a separate setting `restore_messages` in `smp-server.ini` file. Saving messages would only work if the server is stopped with SIGINT signal (keyboard interrupt), if it is stopped with SIGTERM signal the messages would not be saved.
+
 > **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
 
 SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
@@ -61,6 +63,7 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 ### SMP client library
 
 [SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
+
 - execute commands with a functional API.
 - receive messages and other notifications via STM queue.
 - automatically send keep-alive commands.
@@ -118,11 +121,11 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 - Create a Linode account or login with an already existing one.
 - Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode".
 - You can optionally configure the following parameters:
-    - SMP Server store log flag for queue persistence on server restart, recommended.
-    - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
-      - read/write for "linodes"
-      - read/write for "domains"
-    - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
+  - SMP Server store log flag for queue persistence on server restart, recommended.
+  - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
+    - read/write for "linodes"
+    - read/write for "domains"
+  - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
 - Choose the region and plan, Shared CPU Nanode with 1Gb is sufficient.
 - Provide ssh key to be able to connect to your Linode via ssh. If you haven't provided a Linode API token this step is required to login to your Linode and get the server's fingerprint either from the welcome message or from the file `/etc/opt/simplex/fingerprint` after server starts. See [Linode's guide on ssh](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) .
 - Deploy your Linode. After it starts wait for SMP server to start and for tags to appear (if a Linode API token was provided). It may take up to 5 minutes depending on the connection speed on the Linode. Connecting Linode IP address to provided domain name may take some additional time.

apps/smp-server/Main.hs

@@ -7,12 +7,13 @@
 module Main where
 
 import Control.Logger.Simple
+import Data.Functor (($>))
 import Data.Ini (lookupValue)
 import Simplex.Messaging.Server (runSMPServer)
 import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion)
+import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
 import System.FilePath (combine)
 
 cfgPath :: FilePath
@@ -57,9 +58,11 @@ smpServerCLIConfig =
             \# that will be lost on restart (e.g., as with redis).\n\
             \# This option enables saving memory to append only log,\n\
             \# and restoring it when the server is started.\n\
-            \# Log is compacted on start (deleted objects are removed).\n\
-            \# The messages are not logged.\n"
-              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+            \# Log is compacted on start (deleted objects are removed).\n"
+              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n")
+              <> "# The messages are optionally saved and restored when the server restarts,\n\
+                 \# they are deleted after restarting.\n"
+              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
               <> "[TRANSPORT]\n"
               <> ("port: " <> defaultServerPort <> "\n")
               <> "websockets: off\n\n"
@@ -80,6 +83,13 @@ smpServerCLIConfig =
                 privateKeyFile = serverKeyFile,
                 certificateFile = serverCrtFile,
                 storeLogFile,
+                storeMsgsFile =
+                  let messagesPath = combine logPath "smp-server-messages.log"
+                   in case lookupValue "STORE_LOG" "restore_messages" ini of
+                        Right "on" -> Just messagesPath
+                        Right _ -> Nothing
+                        -- if the setting is not set, it is enabled when store log is enabled
+                        _ -> storeLogFile $> messagesPath,
                 allowNewQueues = True,
                 messageExpiration = Just defaultMessageExpiration,
                 inactiveClientExpiration =
@@ -92,6 +102,7 @@ smpServerCLIConfig =
                           }
                     else Nothing,
                 logStatsInterval = Just 86400, -- seconds
-                logStatsStartTime = 0 -- seconds from 00:00 UTC
+                logStatsStartTime = 0, -- seconds from 00:00 UTC
+                smpServerVRange = supportedSMPServerVRange
               }
         }

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 2.1.1
+version: 2.3.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -48,7 +48,7 @@ dependencies:
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
-  - network == 3.1.2.*
+  - network >= 3.1.2.7 && < 3.2
   - network-transport == 0.5.*
   - optparse-applicative >= 0.15 && < 0.17
   - QuickCheck == 2.14.*
@@ -60,9 +60,11 @@ dependencies:
   - template-haskell == 2.16.*
   - text == 1.2.*
   - time == 1.9.*
+  - time-compat == 1.9.*
   - time-manager == 0.0.*
-  - tls >= 1.5.7 && < 1.6
+  - tls >= 1.6.0 && < 1.7
   - transformers == 0.5.*
+  - unix == 2.7.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
   - websockets == 0.12.*

protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd

@@ -0,0 +1,71 @@
+sequenceDiagram
+  participant A as Alice
+  participant AA as Alice's<br>agent
+  participant AS as Alice's<br>server
+  participant BS as Bob's<br>server
+  participant BA as Bob's<br>agent
+  participant B as Bob
+
+  note over AA, BA: status (receive/send): NONE/NONE
+
+  note over A, AA: 1. request connection<br>from agent
+  A ->> AA: NEW: create<br>duplex connection
+ 
+  note over AA, AS: 2. create Alice's SMP queue
+  AA ->> AS: NEW: create SMP queue
+  AS ->> AA: IDS: SMP queue IDs
+  note over AA: status: NEW/NONE
+
+  AA ->> A: INV: invitation<br>to connect
+
+  note over A, B: 3. out-of-band invitation
+  A ->> B: OOB: invitation to connect
+
+  note over BA, B: 4. accept connection
+  B ->> BA: JOIN:<br>via invitation info
+  note over BA: status: NONE/NEW
+
+  note over BA, BS: 5. create Bob's SMP queue
+  BA ->> BS: NEW: create SMP queue
+  BS ->> BA: IDS: SMP queue IDs
+  note over BA: status: NEW/NEW
+
+  note over BA, AA: 6. establish Alice's SMP queue
+  BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
+  note over BA: status: NEW/CONFIRMED
+
+  AS ->> AA: MSG: Bob's info and<br>sender server key
+  note over AA: status: CONFIRMED/NONE
+  AA ->> AS: ACK: confirm message
+  AA ->> A: CONF: connection request ID<br>and Bob's info
+  A ->> AA: LET: accept connection request,<br>send Alice's info
+  AA ->> AS: KEY: secure queue
+  note over AA: status: SECURED/NONE
+
+  AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
+  note over AA: status: SECURED/CONFIRMED
+
+  BS ->> BA: MSG: Alice's info and<br>sender's server key
+  note over BA: status: CONFIRMED/CONFIRMED
+  BA ->> B: INFO: Alice's info
+  BA ->> BS: ACK: confirm message
+  BA ->> BS: KEY: secure queue
+  note over BA: status: SECURED/CONFIRMED
+
+  BA ->> AS: SEND: HELLO: only needs to be sent once in v2
+
+  note over BA: status: SECURED/ACTIVE
+  note over BA, B: 7a. notify Bob<br>about connection success
+  BA ->> B: CON: connected
+
+  AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
+  note over AA: status: SECURED/ACTIVE
+  AA ->> AS: ACK: confirm message
+  note over A, AA: 7a. notify Alice<br>about connection success
+  AA ->> A: CON: connected
+
+  AA ->> BS: SEND: HELLO: only needs to be sent once in v2
+  note over AA: status: ACTIVE/ACTIVE
+  BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
+  note over BA: status: ACTIVE/ACTIVE
+  BA ->> BS: ACK: confirm message

protocol/diagrams/duplex-messaging/duplex-creating.mmd

@@ -33,8 +33,8 @@ sequenceDiagram
   AS ->> AA: MSG: Bob's info and<br>sender server key
   note over AA: status: CONFIRMED/NONE
   AA ->> AS: ACK: confirm message
-  AA ->> A: REQ: connection request ID<br>and Bob's info
-  A ->> AA: ACPT: accept connection request,<br>send Alice's info
+  AA ->> A: CONF: connection request ID<br>and Bob's info
+  A ->> AA: LET: accept connection request,<br>send Alice's info
   AA ->> AS: KEY: secure queue
   note over AA: status: SECURED/NONE
 

protocol/diagrams/notifications/subscription.mmd

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

rfcs/2022-06-13-db-sync.md

@@ -0,0 +1,75 @@
+# DB access and processing messages for iOS notification service extension
+
+## Problem
+
+The only way to receive/process notificaitons is via a separate NSE process that requires a concurrent DB and network access.
+
+SQLite concurenncy does not work, so we need to sync database access.
+
+The problem is complex, as we do not directly control db access from the app, it can be triggered by the message arriving and it may fail to complete in case the app is suspended in the background.
+
+So we need to prevent db access from starting when we know the app is about to be suspended.
+
+The last problem is how to receive and process messages in NSE - should it use recently added GET command or should it subscribe to the connections that receive messages and process messages normally.
+
+To summarize, 2 problems need to be solved:
+
+1. sync db access between 2 (or more, if we add share extension) processes
+
+2. prevent access from starting when the process is due to suspend, only complete operations.
+
+3. Receiveing and processing agent messages in NSE
+
+## Proposed solution
+
+For problem 1, we can use Posix semaphores from our core code, in the same bracket that manages database connection - it would wait for semaphore to be free and unlock it once the db operation is complete.
+
+For problem 2, we need to communicate from the app when it goes to the background to prevent database access starting and completing before the suspension. This would set some `aboutToSuspend` STM flag (or the opposite) that would prevent operations from progressing (using STM retry, that would block until the flag has the value allowing operation to progress).
+
+Several possibilities can be considered:
+
+- use this flag in the bracket that provides DB connections. While simple, it may lock some operations in the middle and may also lead to the situation when network operation succeeds but database access was blocked, and the database is not updated.
+- use this flag to stop network operations that would require database updates - like sending messages, subscriptions and ACK - all these operations would require database access once they succeed.
+- use two flags, for both cases above, but set them at different times since going to background - block new network operations as soon as the app goes to the background and block database access once the app is about to be suspended.
+
+The last option seems more robust. To do it, there will be an api allowing the app to communicat its phase:
+
+- app going to the background would trigger blocking new network operations and start a new background task - `background` phase.
+- background task receiving completion warning, or, maybe, some time after it is started - probably 20 seconds - or whatever happens earlier - would trigger call blocking db access - `suspended` phase.
+- app becoming active would trigger unblocking both flags - `active` phase.
+
+`/_app phase <phase>` where `phase` can be one of the above values.
+
+NSE would also use the same phases:
+
+- sending `active` when it is started (the process starts as active, but it is possible that the new notification arrives to the same process, after the previous one sent background/suspension)
+- sending `background + suspended` (or `suspended` should set both flags) once it is finished processing the notification, provided no new notification arrived and started processing - this should be tracked in NSE.
+
+For problem 3, NSE can do one of the following:
+
+- use SUB and process messages normally - the downside is that the app will have to resubscribe and it has to be tracked.
+- use GET and process messages by pushing them through the processing function - the downside it that a rewiring of message processing is needed.
+- use GET but deliver messages through the same queue as when they arrive normally (in which case getMessage agent function should not return the message, but will return a flag showing whether the message was received, or, possibly, or, possibly will return a message but the message would also be sent to the queue?).
+- process messages in agent manually and in chat via the queue.
+
+One of the downside of GET is that it requires calling GET again after ACK. We could have two variants of ACK (or additional ACK parameter) - one that never delivers a new message, and another one that does. In this case, if get needs to process the next message (when the current one has no notification flag), it can call ACK that delivers the next message. But, it is probably a premature optimization, and having general support of batched commands would add more value.
+
+Additional problem is concurrency in NSE - if the new notification from the same queue arrives before the current one finishes processing in the same process one of the following can happen:
+
+- the 2nd notification naively call GET and receives the same message.
+- the 2nd notification waits until the first finished processing, in which case it can run out of time.
+
+The problem is that the app won't know it's the same queue, as nId is encrypted, so the agent should handle this scenario when the new call to getMessage is made before the previous one finished processing, and differentiate between calls made for additional messages (possibly, getMessage should include previous message ID, if it is available) and the first call.
+
+EDIT: GETs have to be sent from UI to chat and from chat to agent as function calls, but the agent will have to queue get calls to make sure they return different messages. GET call would return message flags (incl. notification flag), so that the UI can send the next GET if needed without waiting.
+
+Considered alternative: include notification content in the message and have NSE only perform decryption, without any network IO. In this case notification content would be in SEND and in NMSG, e2e encrypted.
+
+While promising, as it solves network coordination issues and makes GET unnecessary, it creates mutliple other problems, so it was rejected:
+
+- message content is exposed to centralized ntf and apns servers, creating additional attack vector.
+- it adds complexity in security critical parts of the stack - double ratchet encryption, as it requires either storing message keys and using different IVs for notifications, or initializing completely separate ratchet for notifications content.
+- it reduces the size of the message.
+- it makes user experience worse, as:
+  - it would not accelerate handshake for new contacts and for file delivery - this approach only works for content messages.
+  - it would open the app without the new messages - the users would have to wait until the messages are received. It is also bad for "security optics" - the users might think that the message content was exposed to notifications.

rfcs/2022-06-13-db-sync.mmd

@@ -0,0 +1,61 @@
+sequenceDiagram
+  participant M as iOS message<br>notification
+  participant S as iOS system
+  participant N as iOS NSE
+  participant U as iOS UI
+  participant C as Core chat
+  participant A as Core agent
+
+  M ->> N: notification
+  S ->> N: get app pref
+  note over N: ignore,<br>app is active
+
+  note over M, A: app going to background
+  S ->> U: phase: background<br>(possibly, "will" method)
+  U ->> S: set app pref "pausing"
+  U ->> C: /_app phase paused, result CRCmdOk
+  C ->> A: pauseAgent<br>(no new network IO)
+  M ->> N: notification
+  S ->> N: get app pref
+  note over N: wait/poll for<br>"paused"/"suspending"/"suspended"<br>event/pref
+  A ->> C: event "IO paused"<br>(after in-flight op completed)<br>PHASE PAUSED
+  C ->> U: event "IO paused" (CRAppPaused)
+  U ->> S: set shared pref "paused"
+
+  note over M, A: process notification
+  M ->> N: notification
+  S ->> N: get app pref<br>continue if<br>"paused"/"suspending"/"suspended"
+  N ->> S: set NSE pref "active"
+  N ->> C: /_get message
+  C ->> A: getMessage
+  A ->> C: msg flags
+  C ->> N: msg flags
+  note over N: get messages<br>until notification flag set
+  A ->> C: MSG/CONF/INFO
+  C ->> N: some event
+  N ->> S: set NSE pref "completed"
+  N ->> S: show notification
+
+  note over M, A: app about to be suspended<br>(or 15-20 sec after background)
+  S ->> U: background task notice
+  U ->> S: set app pref "suspending"
+  U ->> C: /_app phase suspended, response ok
+  C ->> A: suspendAgent<br>(no new DB)
+  A ->> C: event "DB paused"<br>(after in-flight op completed)<br>PHASE SUSPENDED
+  C ->> U: event "DB paused" (CRAppSuspended)
+  U ->> S: set app pref "suspended"
+
+  note over M, A: app about to be activated
+  S ->> U: phase: active<br>(or inactive?)<br><br>(possibly, "will" method)
+  S ->> U: get NSE pref
+  U ->> S: set app pref "activating"
+  alt nse active?
+    U ->> C: /_app phase inactive
+    note over U: poll/wait till NSE pref is "completed"
+  end
+
+  U ->> C: /_app phase active (response result)
+  C ->> A: activateAgent<br>(allow IO/DB)
+  A ->> C: result ()
+  C ->> U: CRCmdOk
+  U ->> S: set app pref "active"

rfcs/done/2022-06-05-smp-notifications.md

@@ -0,0 +1,34 @@
+# SMP protocol changes to support push notifications on iOS
+
+## Problem
+
+There are already commands/responses to allow subscriptions to message notifications - NKEY/NID, NSUB/NMSG. These commands will be used by SMP agent (NKEY/NID) and by notification server (NSUB/NMSG) to have message notifications delivered to notification server, so it can forward them to APNS server using device token.
+
+There are two remaining problems that these commands do not solve.
+
+1. Receiving the message when notification arrives.
+
+iOS requires creating a bundled notification service extension (NSE) that runs in isolated container and, if we were to use the existing commands, would have SMP subscription to the same SMP servers as the main app, triggering resubscriptions every time the message reception switches between the app and NSE. That would cause a substantial increase in traffic and battery consumption to the users.
+
+2. Showing notifications for service messages.
+
+Users do not expect to see notifications for every single SMP messages - e.g., we currently do not show notifications when messages are edited and deleted, and users do not expect them. NSE requires that for every received push notification there should be some notification shown to the users. So only we would have to show a notification for message deletes and updates, we would have to show it for all service messages - e.g. user accepted file invitation, or file transmission has started, contact profile updates and so on.
+
+We considered differentiating whether notifications are sent per queue, from the recipient side, so we do not send notifications for file queues. But it seems insufficient, particularly if we add such features as message receipts, status updates, etc.
+
+## Proposal
+
+1. To retrieve messages when push notifications arrive, we will add 2 SMP commands:
+
+- GET: retrieve one message from the connection. Resonse could be either MSG (the same as when MSG is delivered, but with the correlation id) or GMSG (to simplify processing) – TBC during implementation. If message is not available, the response could be ERR NO_MSG
+- ACK or GACK: acknowledge that the message was processed by the client and can be removed - TBC which one is better. The response is OK or ERR NO_MSG if there was nothing to acknowledge (same as with ACK now)
+
+This would allow receiving a single message from the queue without subscription, this way avoiding that the main app is unsubscribed from the queue.
+
+2. The only way to avoid showing unnecessary notifications (status updates, service messages, etc.) is to avoid sending them. That requires instructing SMP server whether notification should be sent both per queue, from the recipient side, and per message - from the sender side. So the notification would only be sent if the queue has them enabled (via NKEY command) and the sender includes an additional flag in SEND command. The same flag should be included into MSG, so when the message is retrieved with GET command, the client knows, on the agent or chat level (or both), whether this message should have notification shown to the user, and if not - retrieve the next one(s) as well.
+
+This is a substantial change to SMP protocol, that would require client and server upgrade for notifications to be supported.
+
+We should consider whether to increase the SMP protocol version number to 2, so that the new clients can connect to the old clients but without notifications, or we could keep the old commands in the protocol and instead of adding flags to the existing commands, create new commands.
+
+We can also consider making commands extensible so that the new flags can be added (and ignored by parsers if not supported) to at least some existing commands.

scripts/smp-server-linode.sh

@@ -157,6 +157,7 @@ Description=SMP server
 [Service]
 Type=simple
 ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
+KillSignal=SIGINT
 Restart=always
 RestartSec=10
 LimitNOFILE=1000000

scripts/update-smp-server.sh

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

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        2.1.1
+version:        2.3.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -37,6 +37,7 @@ library
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
+      Simplex.Messaging.Agent.NtfSubSupervisor
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
       Simplex.Messaging.Agent.RetryInterval
@@ -47,7 +48,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
@@ -116,7 +117,7 @@ library
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.2.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -127,9 +128,11 @@ library
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
+    , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
@@ -175,7 +178,7 @@ executable ntf-server
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.2.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -187,9 +190,11 @@ executable ntf-server
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
+    , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
@@ -235,7 +240,7 @@ executable smp-agent
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.2.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -247,9 +252,11 @@ executable smp-agent
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
+    , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
@@ -295,7 +302,7 @@ executable smp-server
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.2.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -307,9 +314,11 @@ executable smp-server
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
+    , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
@@ -374,7 +383,7 @@ test-suite smp-server-test
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.2.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -386,10 +395,12 @@ test-suite smp-server-test
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
+    , time-compat ==1.9.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
+    , unix ==2.7.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*

src/Simplex/Messaging/Agent/Client.hs

@@ -4,32 +4,38 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
     newAgentClient,
-    AgentMonad,
     withAgentLock,
     closeAgentClient,
     newRcvQueue,
     subscribeQueue,
+    getQueueMessage,
     addSubscription,
+    getSubscriptions,
     sendConfirmation,
     sendInvitation,
     RetryInterval (..),
     secureQueue,
+    enableQueueNotifications,
     sendAgentMessage,
     agentNtfRegisterToken,
     agentNtfVerifyToken,
     agentNtfCheckToken,
     agentNtfDeleteToken,
     agentNtfEnableCron,
+    agentNtfCreateSubscription,
+    agentNtfCheckSubscription,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -39,12 +45,17 @@ module Simplex.Messaging.Agent.Client
     logServer,
     removeSubscription,
     hasActiveSubscription,
+    agentDbPath,
+    beginAgentOperation,
+    endAgentOperation,
+    notifyAgentPhaseChanged,
+    withStore,
   )
 where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (stateTVar)
+import Control.Concurrent.STM (retry, stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
@@ -57,24 +68,28 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes)
+import Data.Set (Set)
 import Data.Text.Encoding
 import Data.Word (Word16)
+import Database.SQLite.Simple (SQLError)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.SQLite (AgentStoreMonad, SQLiteStore (..))
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (bshow, catchAll_, ifM, liftEitherError, liftError, tryError, unlessM, whenM)
 import Simplex.Messaging.Version
+import System.Posix.Semaphore (semPost, semThreadWait)
 import System.Timeout (timeout)
 import UnliftIO (async, pooledForConcurrentlyN)
 import qualified UnliftIO.Exception as E
@@ -92,8 +107,8 @@ data AgentClient = AgentClient
     subQ :: TBQueue (ATransmission 'Agent),
     msgQ :: TBQueue (ServerTransmission BrokerMsg),
     smpServers :: TVar (NonEmpty SMPServer),
-    ntfServers :: TVar [NtfServer],
     smpClients :: TMap SMPServer SMPClientVar,
+    ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
     subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
     pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
@@ -101,11 +116,11 @@ data AgentClient = AgentClient
     connMsgsQueued :: TMap ConnId Bool,
     smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
     smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
+    getMsgLocks :: TMap (ConnId, SMPServer, SMP.RecipientId) (TMVar ()),
     reconnections :: TVar [Async ()],
     asyncClients :: TVar [Async ()],
     clientId :: Int,
     agentEnv :: Env,
-    smpSubscriber :: Async (),
     lock :: TMVar ()
   }
 
@@ -117,8 +132,8 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   subQ <- newTBQueue qSize
   msgQ <- newTBQueue qSize
   smpServers <- newTVar smp
-  ntfServers <- newTVar ntf
   smpClients <- TM.empty
+  ntfServers <- newTVar ntf
   ntfClients <- TM.empty
   subscrSrvrs <- TM.empty
   pendingSubscrSrvrs <- TM.empty
@@ -126,26 +141,27 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   connMsgsQueued <- TM.empty
   smpQueueMsgQueues <- TM.empty
   smpQueueMsgDeliveries <- TM.empty
+  getMsgLocks <- TM.empty
   reconnections <- newTVar []
   asyncClients <- newTVar []
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
   lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, ntfServers, smpClients, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
 
--- | Agent monad with MonadReader Env and MonadError AgentErrorType
-type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
+agentDbPath :: AgentClient -> FilePath
+agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
 
 class ProtocolServerClient msg where
   getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
-  protocolError :: ErrorType -> AgentErrorType
+  clientProtocolError :: ErrorType -> AgentErrorType
 
 instance ProtocolServerClient BrokerMsg where
   getProtocolServerClient = getSMPServerClient
-  protocolError = SMP
+  clientProtocolError = SMP
 
 instance ProtocolServerClient NtfResponse where
   getProtocolServerClient = getNtfServerClient
-  protocolError = NTF
+  clientProtocolError = NTF
 
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
@@ -184,10 +200,11 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
             _ -> TM.insert srv cVar ps
 
     serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
-    serverDown u cs = unless (M.null cs) $ do
-      let conns = M.keys cs
-      unless (null conns) . notifySub "" $ DOWN srv conns
-      whenM (readTVarIO active) $ unliftIO u reconnectServer
+    serverDown u cs = unless (M.null cs) $
+      whenM (readTVarIO active) $ do
+        let conns = M.keys cs
+        unless (null conns) . notifySub "" $ DOWN srv conns
+        unliftIO u reconnectServer
 
     reconnectServer :: m ()
     reconnectServer = do
@@ -205,6 +222,9 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
       n <- asks $ resubscriptionConcurrency . config
       withAgentLock c . withClient c srv $ \smp -> do
         cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSubscrSrvrs c)
+        -- TODO if any of the subscriptions fails here (e.g. because of timeout), it terminates the whole process for all subscriptions
+        -- instead it should only report successful subscriptions and schedule the next call to reconnectClient to subscribe for the remaining subscriptions
+        -- this way, for each DOWN event there can be several UP events
         conns <- pooledForConcurrentlyN n (maybe [] M.toList cs) $ \sub@(connId, _) ->
           ifM
             (atomically $ hasActiveSubscription c connId)
@@ -304,21 +324,31 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
 closeAgentClient :: MonadIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
-  closeSMPServerClients c
+  closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
+  closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
   cancelActions $ reconnections c
   cancelActions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
-
-closeSMPServerClients :: AgentClient -> IO ()
-closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
+  clear subscrSrvrs
+  clear pendingSubscrSrvrs
+  clear subscrConns
+  clear connMsgsQueued
+  clear smpQueueMsgQueues
   where
-    closeClient smpVar =
-      atomically (readTMVar smpVar) >>= \case
-        Right smp -> closeProtocolClient smp `catchAll_` pure ()
+    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
+    clear :: (AgentClient -> TMap k a) -> IO ()
+    clear sel = atomically $ writeTVar (sel c) M.empty
+
+closeProtocolServerClients :: Int -> TMap ProtocolServer (ClientVar msg) -> IO ()
+closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+  where
+    closeClient cVar =
+      tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
+        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
         _ -> pure ()
 
-cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
+cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
+cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel >> atomically (writeTVar as mempty)
 
 withAgentLock :: MonadUnliftIO m => AgentClient -> m a -> m a
 withAgentLock AgentClient {lock} =
@@ -342,10 +372,10 @@ withLogClient_ c srv qId cmdStr action = do
   return res
 
 withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withClient c srv action = withClient_ c srv $ liftClient (protocolError @msg) . action
+withClient c srv action = withClient_ c srv $ liftClient (clientProtocolError @msg) . action
 
 withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (protocolError @msg) . action
+withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (clientProtocolError @msg) . action
 
 liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
 liftClient = liftError . protocolClientError
@@ -389,12 +419,16 @@ newRcvQueue_ a c srv = do
             e2ePrivKey,
             e2eDhSecret = Nothing,
             sndId = Just sndId,
-            status = New
+            status = New,
+            ntfPublicKey = Nothing,
+            ntfPrivateKey = Nothing,
+            notifierId = Nothing
           }
   pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
 
 subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
 subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
+  whenM (atomically . TM.member (connId, server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
   atomically $ addPendingSubscription c rq connId
   withLogClient c server rcvId "SUB" $ \smp -> do
     liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
@@ -402,7 +436,8 @@ subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
         atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
           removePendingSubscription c server connId
         throwError e
-      Right _ -> addSubscription c rq connId
+      Right _ -> do
+        addSubscription c rq connId
 
 addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
 addSubscription c rq@RcvQueue {server} connId = atomically $ do
@@ -434,6 +469,11 @@ removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> S
 removeSubs_ ss server connId =
   TM.lookup server ss >>= mapM_ (TM.delete connId)
 
+getSubscriptions :: AgentClient -> STM (Set ConnId)
+getSubscriptions AgentClient {subscrConns} = do
+  m <- readTVar subscrConns
+  pure $ M.keysSet m
+
 logServer :: MonadIO m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
   logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
@@ -450,31 +490,54 @@ sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey,
   withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
     let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
     msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp Nothing sndId msg
+    liftClient SMP $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg
 sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
 sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
 sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
   withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
     msg <- mkInvitation
-    liftClient SMP $ sendSMPMessage smp Nothing senderId msg
+    liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
   where
     mkInvitation :: m ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
     mkInvitation = do
-      let agentEnvelope = AgentInvitation {agentVersion = smpAgentVersion, connReq, connInfo}
+      agentVersion <- asks $ smpAgentVersion . config
+      let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
       agentCbEncryptOnce dhPublicKey . smpEncode $
         SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
 
+getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m (Maybe (MsgId, MsgFlags))
+getQueueMessage c@AgentClient {getMsgLocks} RcvQueue {server, rcvId, rcvPrivateKey} connId =
+  E.bracket (atomically createTakeLock) (atomically . (`putTMVar` ())) $ \_ ->
+    withLogClient c server rcvId "GET" $ \smp ->
+      getSMPMessage smp rcvPrivateKey rcvId
+  where
+    k = (connId, server, rcvId)
+    createTakeLock = do
+      l <- TM.lookup k getMsgLocks >>= maybe newLock pure
+      takeTMVar l
+      pure l
+      where
+        newLock = do
+          l <- newTMVar ()
+          TM.insert k l getMsgLocks
+          pure l
+
 secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
 secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
   withLogClient c server rcvId "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
-sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
-sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
+enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> m NotifierId
+enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey =
+  withLogClient c server rcvId "NKEY <nkey>" $ \smp ->
+    enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey
+
+sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
+sendAck c RcvQueue {server, rcvId, rcvPrivateKey} msgId =
   withLogClient c server rcvId "ACK" $ \smp ->
-    ackSMPMessage smp rcvPrivateKey rcvId
+    ackSMPMessage smp rcvPrivateKey rcvId msgId
 
 suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
@@ -486,12 +549,12 @@ deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
   withLogClient c server rcvId "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
-sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
-sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
+sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
+sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msgFlags agentMsg =
   withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
     let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
     msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
+    liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg
 
 agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
 agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
@@ -513,6 +576,14 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W
 agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
   withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
 
+agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId
+agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
+  withLogClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
+
+agentNtfCheckSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m NtfSubStatus
+agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
+  withLogClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
+
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
@@ -550,4 +621,54 @@ cryptoError = \case
   C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
   C.AESDecryptError -> AGENT A_ENCRYPTION
   C.CBDecryptError -> AGENT A_ENCRYPTION
+  C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
   e -> INTERNAL $ show e
+
+endAgentOperation :: AgentClient -> AgentOperation -> STM ()
+endAgentOperation c@AgentClient {agentEnv = Env {agentOperations}} op = do
+  TM.alter (Just . maybe 0 (\n -> min 0 $ n - 1)) op agentOperations
+  notifyAgentPhaseChanged c
+
+beginAgentOperation :: AgentClient -> AgentOperation -> STM ()
+beginAgentOperation AgentClient {agentEnv = Env {agentPhase, agentOperations}} op = do
+  (p, _) <- readTVar agentPhase
+  when (op `elem` disallowedOperations p) retry
+  TM.alter (Just . maybe 1 (+ 1)) op agentOperations
+
+notifyAgentPhaseChanged :: AgentClient -> STM ()
+notifyAgentPhaseChanged AgentClient {subQ, agentEnv = Env {agentPhase, agentOperations}} = do
+  (p, notified) <- readTVar agentPhase
+  unless notified $ do
+    ops <- readTVar agentOperations
+    let opsPaused = all (maybe True (== 0) . (`M.lookup` ops)) $ disallowedOperations p
+    when opsPaused $ do
+      writeTBQueue subQ ("", "", PHASE p)
+      writeTVar agentPhase (p, True)
+
+withStore :: AgentMonad m => AgentClient -> (forall m'. AgentStoreMonad m' => SQLiteStore -> m' a) -> m a
+withStore c action = do
+  st@SQLiteStore {dbSemaphore} <- asks store
+  E.bracket_ (liftIO $ mapM_ semThreadWait dbSemaphore) (liftIO $ mapM_ semPost dbSemaphore) $ do
+    atomically $ beginAgentOperation c AODatabase
+    r <- runExceptT (action st `E.catch` handleInternal)
+    atomically $ endAgentOperation c AODatabase
+    case r of
+      Right res -> pure res
+      Left e -> throwError $ storeError e
+  where
+    -- TODO when parsing exception happens in store, the agent hangs;
+    -- changing SQLError to SomeException does not help
+    handleInternal :: (MonadError StoreError m') => SQLError -> m' a
+    handleInternal e = throwError . SEInternal $ bshow e
+    storeError :: StoreError -> AgentErrorType
+    storeError = \case
+      SEConnNotFound -> CONN NOT_FOUND
+      SEConnDuplicate -> CONN DUPLICATE
+      SEBadConnType CRcv -> CONN SIMPLEX
+      SEBadConnType CSnd -> CONN SIMPLEX
+      SEInvitationNotFound -> CMD PROHIBITED
+      -- this error is never reported as store error,
+      -- it is used to wrap agent operations when "transaction-like" store access is needed
+      -- NOTE: network IO should NOT be used inside AgentStoreMonad
+      SEAgentError e -> e
+      e -> INTERNAL $ show e

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

@@ -1,37 +1,57 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Env.SQLite
-  ( AgentConfig (..),
+  ( AgentMonad,
+    AgentConfig (..),
     InitialAgentServers (..),
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
+    AgentOperation (..),
+    disallowedOperations,
     newSMPAgentEnv,
+    NtfSupervisor (..),
+    NtfSupervisorCommand (..),
   )
 where
 
+import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Network.Socket
 import Numeric.Natural
-import Simplex.Messaging.Agent.Protocol (SMPServer)
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
+import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Client (NtfServer)
+import Simplex.Messaging.Notifications.Client (NtfServer, NtfToken)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
+import UnliftIO (Async)
 import UnliftIO.STM
 
+-- | Agent monad with MonadReader Env and MonadError AgentErrorType
+type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
+
 data InitialAgentServers = InitialAgentServers
   { smp :: NonEmpty SMPServer,
     ntf :: [NtfServer]
@@ -43,16 +63,20 @@ data AgentConfig = AgentConfig
     connIdBytes :: Int,
     tbqSize :: Natural,
     dbFile :: FilePath,
-    dbPoolSize :: Int,
+    dbSemName :: Maybe String,
     yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
     helloTimeout :: NominalDiffTime,
     resubscriptionConcurrency :: Int,
+    ntfWorkerThrottle :: Int,
+    ntfSubCheckInterval :: NominalDiffTime,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    smpAgentVersion :: Version,
+    smpAgentVRange :: VersionRange
   }
 
 defaultReconnectInterval :: RetryInterval
@@ -73,18 +97,22 @@ defaultAgentConfig =
       connIdBytes = 12,
       tbqSize = 64,
       dbFile = "smp-agent.db",
-      dbPoolSize = 4,
+      dbSemName = Nothing,
       yesToMigrations = False,
       smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
       reconnectInterval = defaultReconnectInterval,
       helloTimeout = 2 * nominalDay,
       resubscriptionConcurrency = 16,
+      ntfWorkerThrottle = 1000000, -- microseconds
+      ntfSubCheckInterval = nominalDay,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
       privateKeyFile = "/etc/opt/simplex-agent/agent.key",
-      certificateFile = "/etc/opt/simplex-agent/agent.crt"
+      certificateFile = "/etc/opt/simplex-agent/agent.crt",
+      smpAgentVersion = currentSMPAgentVersion,
+      smpAgentVRange = supportedSMPAgentVRange
     }
 
 data Env = Env
@@ -92,13 +120,45 @@ data Env = Env
     store :: SQLiteStore,
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
-    randomServer :: TVar StdGen
+    randomServer :: TVar StdGen,
+    agentPhase :: TVar (AgentPhase, Bool),
+    agentOperations :: TMap AgentOperation Int,
+    ntfSupervisor :: NtfSupervisor
   }
 
+data AgentOperation = AONetwork | AODatabase
+  deriving (Eq, Ord)
+
+disallowedOperations :: AgentPhase -> [AgentOperation]
+disallowedOperations = \case
+  APActive -> []
+  APPaused -> [AONetwork]
+  APSuspended -> [AONetwork, AODatabase]
+
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {dbFile, dbPoolSize, yesToMigrations} = do
+newSMPAgentEnv config@AgentConfig {dbFile, dbSemName, yesToMigrations} = do
   idsDrg <- newTVarIO =<< drgNew
-  store <- liftIO $ createSQLiteStore dbFile dbPoolSize Migrations.app yesToMigrations
+  store <- liftIO $ createSQLiteStore dbFile dbSemName Migrations.app yesToMigrations
   clientCounter <- newTVarIO 0
   randomServer <- newTVarIO =<< liftIO newStdGen
-  return Env {config, store, idsDrg, clientCounter, randomServer}
+  agentPhase <- newTVarIO (APActive, True)
+  agentOperations <- atomically TM.empty
+  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
+  return Env {config, store, idsDrg, clientCounter, randomServer, agentPhase, agentOperations, ntfSupervisor}
+
+data NtfSupervisor = NtfSupervisor
+  { ntfTkn :: TVar (Maybe NtfToken),
+    ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
+    ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
+    ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
+  }
+
+data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCNtfWorker NtfServer
+
+newNtfSubSupervisor :: Natural -> STM NtfSupervisor
+newNtfSubSupervisor qSize = do
+  ntfTkn <- newTVar Nothing
+  ntfSubQ <- newTBQueue qSize
+  ntfWorkers <- TM.empty
+  ntfSMPWorkers <- TM.empty
+  pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -0,0 +1,252 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.NtfSubSupervisor
+  ( runNtfSupervisor,
+    nsUpdateToken,
+    nsRemoveNtfToken,
+    sendNtfSubCommand,
+    closeNtfSupervisor,
+    getNtfServer,
+  )
+where
+
+import Control.Concurrent.Async (Async, uninterruptibleCancel)
+import Control.Concurrent.STM (stateTVar)
+import Control.Monad
+import Control.Monad.Except (runExceptT)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Reader
+import Data.Bifunctor (first)
+import Data.Fixed (Fixed (MkFixed), Pico)
+import qualified Data.Map.Strict as M
+import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+import Simplex.Messaging.Agent.Client
+import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Protocol (ConnId)
+import qualified Simplex.Messaging.Agent.Protocol as AP
+import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Client.Agent ()
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Client
+import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (unlessM)
+import System.Random (randomR)
+import UnliftIO (async)
+import UnliftIO.Concurrent (forkIO, threadDelay)
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+runNtfSupervisor :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runNtfSupervisor c = forever $ do
+  ns <- asks ntfSupervisor
+  cmd <- atomically . readTBQueue $ ntfSubQ ns
+  runExceptT (processNtfSub c cmd) >>= \case
+    Left e -> liftIO $ print e
+    Right _ -> return ()
+
+processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
+processNtfSub c (connId, cmd) = do
+  ntfServer_ <- getNtfServer c
+  case cmd of
+    NSCCreate -> do
+      -- TODO merge getNtfSubscription and getRcvQueue into one method to read both in same transaction?
+      sub_ <- withStore c $ \st -> getNtfSubscription st connId
+      RcvQueue {notifierId, server = smpServer} <- withStore c $ \st -> getRcvQueue st connId
+      case (sub_, ntfServer_) of
+        (Nothing, Just ntfServer) -> do
+          currentTime <- liftIO getCurrentTime
+          case notifierId of
+            (Just nId) -> do
+              let newSub = newNtfSubscription connId smpServer (Just nId) ntfServer NASKey currentTime
+              withStore c $ \st -> createNtfSubscription st newSub (NtfSubAction NSACreate)
+            _ -> do
+              let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew currentTime
+              withStore c $ \st -> createNtfSubscription st newSub (NtfSubSMPAction NSAKey)
+          -- TODO optimize?
+          -- TODO - read action in getNtfSubscription and decide which worker to create
+          -- TODO - SMP worker can create Ntf worker on NKEY completion
+          addNtfSMPWorker smpServer
+          addNtfWorker ntfServer
+        (Just _, Just ntfServer) -> do
+          -- TODO subscription may have to be updated depending on current state:
+          -- TODO - e.g., if it was previously marked for deletion action has to be updated
+          -- TODO - should action depend on subscription status or always be NSAKey (NSACreate if notifierId exists)
+          -- TODO   in case worker is currently deleting it? When deleting worker should check for updated_by_supervisor
+          -- TODO   and if it is set perform update instead of delete. If worker was not deleting it yet it should
+          -- TODO   idempotently replay commands.
+          addNtfSMPWorker smpServer
+          addNtfWorker ntfServer
+        _ -> pure () -- error - notification server not configured
+    NSCDelete -> do
+      -- TODO delete notifier ID and Key from SMP server (SDEL, then NDEL)
+      withStore c $ \st -> markNtfSubscriptionForDeletion st connId
+      case ntfServer_ of
+        (Just ntfServer) -> addNtfWorker ntfServer
+        _ -> pure ()
+    NSCNtfWorker ntfServer ->
+      addNtfWorker ntfServer
+  where
+    addNtfWorker = addWorker ntfWorkers runNtfWorker
+    addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
+    addWorker ::
+      (NtfSupervisor -> TMap ProtocolServer (TMVar (), Async ())) ->
+      (AgentClient -> ProtocolServer -> TMVar () -> m ()) ->
+      ProtocolServer ->
+      m ()
+    addWorker wsSel runWorker srv = do
+      ws <- asks $ wsSel . ntfSupervisor
+      atomically (TM.lookup srv ws) >>= \case
+        Nothing -> do
+          doWork <- newTMVarIO ()
+          worker <- async $ runWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
+          atomically $ TM.insert srv (doWork, worker) ws
+        Just (doWork, _) ->
+          void . atomically $ tryPutTMVar doWork ()
+
+runNtfWorker :: AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
+runNtfWorker c srv doWork = forever $ do
+  void . atomically $ readTMVar doWork
+  getNtfToken >>= \case
+    Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus} -> do
+      nextSub_ <- withStore c (`getNextNtfSubAction` srv)
+      ts <- liftIO getCurrentTime
+      case nextSub_ of
+        Nothing -> noWorkToDo
+        Just (ntfSub@NtfSubscription {connId, smpServer, ntfSubId}, ntfSubAction, RcvQueue {ntfPrivateKey, notifierId}) ->
+          unlessM (rescheduleAction doWork ts ntfSub) $
+            case ntfSubAction of
+              NSACreate -> case (ntfPrivateKey, notifierId) of
+                (Just ntfPrivKey, Just nId)
+                  | ntfTknStatus == NTActive -> do
+                    nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer nId) ntfPrivKey
+                    let actionTs = addUTCTime 30 ts
+                    withStore c $ \st ->
+                      updateNtfSubscription st connId ntfSub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew, ntfSubActionTs = actionTs} (NtfSubAction NSACheck)
+                  | otherwise -> ntfInternalError c connId "NSACreate - token not active"
+                _ -> ntfInternalError c connId "NSACreate - no notifier key or ID"
+              NSACheck -> case ntfSubId of
+                Just nSubId ->
+                  agentNtfCheckSubscription c nSubId tkn >>= \case
+                    NSNew -> updateSubNextCheck NSNew
+                    NSPending -> updateSubNextCheck NSPending
+                    NSActive -> updateSubNextCheck NSActive
+                    NSEnd -> updateSubNextCheck NSEnd
+                    NSSMPAuth -> updateSub (NASCreated NSSMPAuth) (NtfSubAction NSADelete) ts
+                Nothing -> ntfInternalError c connId "NSACheck - no subscription ID"
+              NSADelete -> pure ()
+          where
+            updateSubNextCheck toStatus = do
+              checkInterval <- asks $ ntfSubCheckInterval . config
+              let nextCheckTs = addUTCTime checkInterval ts
+              updateSub (NASCreated toStatus) (NtfSubAction NSACheck) nextCheckTs
+            updateSub toStatus toAction actionTs =
+              withStore c $ \st ->
+                updateNtfSubscription st connId ntfSub {ntfSubStatus = toStatus, ntfSubActionTs = actionTs} toAction
+    _ -> noWorkToDo
+  delay <- asks $ ntfWorkerThrottle . config
+  liftIO $ threadDelay delay
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+
+runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
+runNtfSMPWorker c srv doWork = forever $ do
+  void . atomically $ readTMVar doWork
+  getNtfToken >>= \case
+    Just NtfToken {ntfTknStatus} -> do
+      nextSub_ <- withStore c (`getNextNtfSubSMPAction` srv)
+      ts <- liftIO getCurrentTime
+      case nextSub_ of
+        Nothing -> noWorkToDo
+        Just (ntfSub@NtfSubscription {connId, ntfServer}, ntfSubAction, rq@RcvQueue {ntfPublicKey}) ->
+          unlessM (rescheduleAction doWork ts ntfSub) $
+            case ntfSubAction of
+              NSAKey
+                | ntfTknStatus == NTActive ->
+                  case ntfPublicKey of
+                    Just ntfPubKey ->
+                      enableNotificationsWithNKey ntfPubKey
+                    _ -> do
+                      C.SignAlg a <- asks (cmdSignAlg . config)
+                      (ntfPubKey, ntfPrivKey) <- liftIO $ C.generateSignatureKeyPair a
+                      withStore c $ \st -> setRcvQueueNotifierKey st connId ntfPubKey ntfPrivKey
+                      enableNotificationsWithNKey ntfPubKey
+                | otherwise -> ntfInternalError c connId "NSAKey - token not active"
+                where
+                  enableNotificationsWithNKey ntfPubKey = do
+                    nId <- enableQueueNotifications c rq ntfPubKey
+                    withStore c $ \st -> do
+                      setRcvQueueNotifierId st connId nId
+                      updateNtfSubscription st connId ntfSub {ntfQueueId = Just nId, ntfSubStatus = NASKey, ntfSubActionTs = ts} (NtfSubAction NSACreate)
+                    ns <- asks ntfSupervisor
+                    atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
+    _ -> noWorkToDo
+  delay <- asks $ ntfWorkerThrottle . config
+  liftIO $ threadDelay delay
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+
+rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> NtfSubscription -> m Bool
+rescheduleAction doWork ts NtfSubscription {ntfSubActionTs}
+  | ntfSubActionTs <= ts = pure False
+  | otherwise = do
+    void . atomically $ tryTakeTMVar doWork
+    void . forkIO $ do
+      threadDelay $ diffInMicros ntfSubActionTs ts
+      void . atomically $ tryPutTMVar doWork ()
+    pure True
+
+fromPico :: Pico -> Integer
+fromPico (MkFixed i) = i
+
+diffInMicros :: UTCTime -> UTCTime -> Int
+diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
+
+ntfInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
+ntfInternalError c@AgentClient {subQ} connId internalErrStr = do
+  withStore c $ \st -> setNullNtfSubscriptionAction st connId
+  atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
+
+getNtfToken :: AgentMonad m => m (Maybe NtfToken)
+getNtfToken = do
+  tkn <- asks $ ntfTkn . ntfSupervisor
+  readTVarIO tkn
+
+nsUpdateToken :: NtfSupervisor -> NtfToken -> STM ()
+nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
+
+nsRemoveNtfToken :: NtfSupervisor -> STM ()
+nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
+
+sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
+sendNtfSubCommand ns cmd =
+  readTVar (ntfTkn ns)
+    >>= mapM_ (\NtfToken {ntfTknStatus} -> when (ntfTknStatus == NTActive) $ writeTBQueue (ntfSubQ ns) cmd)
+
+closeNtfSupervisor :: NtfSupervisor -> IO ()
+closeNtfSupervisor ns = do
+  cancelNtfWorkers_ $ ntfWorkers ns
+  cancelNtfWorkers_ $ ntfSMPWorkers ns
+
+cancelNtfWorkers_ :: TMap ProtocolServer (TMVar (), Async ()) -> IO ()
+cancelNtfWorkers_ wsVar = do
+  ws <- atomically $ stateTVar wsVar $ \ws -> (ws, M.empty)
+  forM_ ws $ uninterruptibleCancel . snd
+
+getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
+getNtfServer c = do
+  ntfServers <- readTVarIO $ ntfServers c
+  case ntfServers of
+    [] -> pure Nothing
+    [srv] -> pure $ Just srv
+    servers -> do
+      gen <- asks randomServer
+      atomically . stateTVar gen $
+        first (Just . (servers !!)) . randomR (0, length servers - 1)

src/Simplex/Messaging/Agent/Protocol.hs

@@ -32,8 +32,8 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
 module Simplex.Messaging.Agent.Protocol
   ( -- * Protocol parameters
-    smpAgentVersion,
-    smpAgentVRange,
+    currentSMPAgentVersion,
+    supportedSMPAgentVRange,
     e2eEncConnInfoLength,
     e2eEncUserMsgLength,
 
@@ -82,6 +82,7 @@ module Simplex.Messaging.Agent.Protocol
     QueueStatus (..),
     ACorrId,
     AgentMsgId,
+    AgentPhase (..),
 
     -- * Encode/decode
     serializeCommand,
@@ -110,7 +111,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Composition ((.:))
+import Data.Composition ((.:), (.:.))
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind (Type)
@@ -132,6 +133,7 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( ErrorType,
     MsgBody,
+    MsgFlags,
     MsgId,
     SMPServer,
     SndPublicVerifyKey,
@@ -146,11 +148,11 @@ import Test.QuickCheck (Arbitrary (..))
 import Text.Read
 import UnliftIO.Exception (Exception)
 
-smpAgentVersion :: Version
-smpAgentVersion = 1
+currentSMPAgentVersion :: Version
+currentSMPAgentVersion = 2
 
-smpAgentVRange :: VersionRange
-smpAgentVRange = mkVersionRange 1 smpAgentVersion
+supportedSMPAgentVRange :: VersionRange
+supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
 
 -- it is shorter to allow all handshake headers,
 -- including E2E (double-ratchet) parameters and
@@ -212,21 +214,44 @@ data ACommand (p :: AParty) where
   END :: ACommand Agent
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent
   UP :: SMPServer -> [ConnId] -> ACommand Agent
-  SEND :: MsgBody -> ACommand Client
+  SEND :: MsgFlags -> MsgBody -> ACommand Client
   MID :: AgentMsgId -> ACommand Agent
   SENT :: AgentMsgId -> ACommand Agent
   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
-  MSG :: MsgMeta -> MsgBody -> ACommand Agent
+  MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent
   ACK :: AgentMsgId -> ACommand Client
   OFF :: ACommand Client
   DEL :: ACommand Client
   OK :: ACommand Agent
   ERR :: AgentErrorType -> ACommand Agent
+  PHASE :: AgentPhase -> ACommand Agent
 
 deriving instance Eq (ACommand p)
 
 deriving instance Show (ACommand p)
 
+-- | Agent phase allows to have two agent processes concurrently working with the same database
+data AgentPhase
+  = -- | agent is operating normally
+    APActive
+  | -- | agent is paused - no new send/receive operations will be started - they will STM-retry
+    APPaused
+  | -- | agent is suspended - no new send/receive/database operations will be started - they will STM-retry
+    APSuspended
+  deriving (Eq, Show)
+
+instance StrEncoding AgentPhase where
+  strEncode = \case
+    APActive -> "ACTIVE"
+    APPaused -> "PAUSED"
+    APSuspended -> "SUSPENDED"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "ACTIVE" -> pure APActive
+      "PAUSED" -> pure APPaused
+      "SUSPENDED" -> pure APSuspended
+      _ -> fail "bad AgentPhase"
+
 data ConnectionMode = CMInvitation | CMContact
   deriving (Eq, Show)
 
@@ -287,7 +312,9 @@ data SMPConfirmation = SMPConfirmation
     -- | sender's DH public key for simple per-queue e2e encryption
     e2ePubKey :: C.PublicKeyX25519,
     -- | sender's information to be associated with the connection, e.g. sender's profile information
-    connInfo :: ConnInfo
+    connInfo :: ConnInfo,
+    -- | optional reply queues included in confirmation (added in agent protocol v2)
+    smpReplyQueues :: [SMPQueueInfo]
   }
   deriving (Show)
 
@@ -333,31 +360,40 @@ instance Encoding AgentMsgEnvelope where
 
 -- SMP agent message formats (after double ratchet decryption,
 -- or in case of AgentInvitation - in plain text body)
-data AgentMessage = AgentConnInfo ConnInfo | AgentMessage APrivHeader AMessage
+data AgentMessage
+  = AgentConnInfo ConnInfo
+  | -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
+    -- It makes REPLY message unnecessary.
+    AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
+  | AgentMessage APrivHeader AMessage
   deriving (Show)
 
 instance Encoding AgentMessage where
   smpEncode = \case
     AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
+    AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
     AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
   smpP =
     smpP >>= \case
       'I' -> AgentConnInfo . unTail <$> smpP
+      'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
       'M' -> AgentMessage <$> smpP <*> smpP
       _ -> fail "bad AgentMessage"
 
-data AgentMessageType = AM_CONN_INFO | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
+data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
   deriving (Eq, Show)
 
 instance Encoding AgentMessageType where
   smpEncode = \case
     AM_CONN_INFO -> "C"
+    AM_CONN_INFO_REPLY -> "D"
     AM_HELLO_ -> "H"
     AM_REPLY_ -> "R"
     AM_A_MSG_ -> "M"
   smpP =
     A.anyChar >>= \case
       'C' -> pure AM_CONN_INFO
+      'D' -> pure AM_CONN_INFO_REPLY
       'H' -> pure AM_HELLO_
       'R' -> pure AM_REPLY_
       'M' -> pure AM_A_MSG_
@@ -366,8 +402,14 @@ instance Encoding AgentMessageType where
 agentMessageType :: AgentMessage -> AgentMessageType
 agentMessageType = \case
   AgentConnInfo _ -> AM_CONN_INFO
+  AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
   AgentMessage _ aMsg -> case aMsg of
+    -- HELLO is used both in v1 and in v2, but differently.
+    -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
+    --   until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
+    -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
     HELLO -> AM_HELLO_
+    -- REPLY is only used in v1
     REPLY _ -> AM_REPLY_
     A_MSG _ -> AM_A_MSG_
 
@@ -765,6 +807,8 @@ data SMPAgentError
     A_VERSION
   | -- | cannot decrypt message
     A_ENCRYPTION
+  | -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
+    A_DUPLICATE
   deriving (Eq, Generic, Read, Show, Exception)
 
 instance ToJSON SMPAgentError where
@@ -840,13 +884,13 @@ commandP =
     acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
     rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
     infoCmd = ACmd SAgent . INFO <$> A.takeByteString
-    downsResp = ACmd SAgent .: DOWN <$> strP <* A.space <*> connections
-    upsResp = ACmd SAgent .: UP <$> strP <* A.space <*> connections
-    sendCmd = ACmd SClient . SEND <$> A.takeByteString
+    downsResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
+    upsResp = ACmd SAgent .: UP <$> strP_ <*> connections
+    sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> A.takeByteString
     msgIdResp = ACmd SAgent . MID <$> A.decimal
     sentResp = ACmd SAgent . SENT <$> A.decimal
     msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
-    message = ACmd SAgent .: MSG <$> msgMetaP <* A.space <*> A.takeByteString
+    message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
     ackCmd = ACmd SClient . ACK <$> A.decimal
     connections = strP `A.sepBy'` (A.char ',')
     msgMetaP = do
@@ -877,17 +921,18 @@ serializeCommand = \case
   END -> "END"
   DOWN srv conns -> B.unwords ["DOWN", strEncode srv, connections conns]
   UP srv conns -> B.unwords ["UP", strEncode srv, connections conns]
-  SEND msgBody -> "SEND " <> serializeBinary msgBody
+  SEND msgFlags msgBody -> "SEND " <> smpEncode msgFlags <> " " <> serializeBinary msgBody
   MID mId -> "MID " <> bshow mId
   SENT mId -> "SENT " <> bshow mId
   MERR mId e -> B.unwords ["MERR", bshow mId, strEncode e]
-  MSG msgMeta msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, serializeBinary msgBody]
+  MSG msgMeta msgFlags msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, smpEncode msgFlags, serializeBinary msgBody]
   ACK mId -> "ACK " <> bshow mId
   OFF -> "OFF"
   DEL -> "DEL"
   CON -> "CON"
   ERR e -> "ERR " <> strEncode e
   OK -> "OK"
+  PHASE p -> "PHASE " <> strEncode p
   where
     showTs :: UTCTime -> ByteString
     showTs = B.pack . formatISO8601Millis
@@ -953,8 +998,8 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
 
     cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
     cmdWithMsgBody = \case
-      SEND body -> SEND <$$> getBody body
-      MSG msgMeta body -> MSG msgMeta <$$> getBody body
+      SEND msgFlags body -> SEND msgFlags <$$> getBody body
+      MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
       JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
       CONF confId cInfo -> CONF confId <$$> getBody cInfo
       LET confId cInfo -> LET confId <$$> getBody cInfo

src/Simplex/Messaging/Agent/Store.hs

@@ -24,12 +24,17 @@ import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfTknStatus, NtfTokenId)
 import Simplex.Messaging.Protocol
   ( MsgBody,
+    MsgFlags,
     MsgId,
+    NotifierId,
+    NtfPrivateSignKey,
+    NtfPublicVerifyKey,
     RcvDhSecret,
     RcvPrivateSignKey,
     SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Version
 
 -- * Store management
 
@@ -46,12 +51,18 @@ class Monad m => MonadAgentStore s m where
   setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
   setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
   setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
+  getRcvQueue :: s -> ConnId -> m RcvQueue
+
+  -- RcvQueue notifier key and ID
+  setRcvQueueNotifierKey :: s -> ConnId -> NtfPublicVerifyKey -> NtfPrivateSignKey -> m ()
+  setRcvQueueNotifierId :: s -> ConnId -> NotifierId -> m ()
 
   -- Confirmations
   createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
   acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
   getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
   removeConfirmations :: s -> ConnId -> m ()
+  setHandshakeVersion :: s -> ConnId -> Version -> Bool -> m ()
 
   -- Invitations - sent via Contact connections
   createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
@@ -64,9 +75,10 @@ class Monad m => MonadAgentStore s m where
   createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
   updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
   createSndMsg :: s -> ConnId -> SndMsgData -> m ()
-  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, PendingMsgData)
   getPendingMsgs :: s -> ConnId -> m [InternalId]
-  checkRcvMsg :: s -> ConnId -> InternalId -> m ()
+  setMsgUserAck :: s -> ConnId -> InternalId -> m MsgId
+  getLastMsg :: s -> ConnId -> SMP.MsgId -> m (Maybe RcvMsg)
   deleteMsg :: s -> ConnId -> InternalId -> m ()
 
   -- Double ratchet persistence
@@ -79,12 +91,21 @@ class Monad m => MonadAgentStore s m where
 
   -- Notification device token persistence
   createNtfToken :: s -> NtfToken -> m ()
-
   getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
   updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
   updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
   removeNtfToken :: s -> NtfToken -> m ()
 
+  -- Notification subscription persistence
+  getNtfSubscription :: s -> ConnId -> m (Maybe NtfSubscription)
+  createNtfSubscription :: s -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  markNtfSubscriptionForDeletion :: s -> ConnId -> m ()
+  updateNtfSubscription :: s -> ConnId -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  setNullNtfSubscriptionAction :: s -> ConnId -> m ()
+  deleteNtfSubscription :: s -> ConnId -> m ()
+  getNextNtfSubAction :: s -> NtfServer -> m (Maybe (NtfSubscription, NtfSubAction, RcvQueue))
+  getNextNtfSubSMPAction :: s -> SMPServer -> m (Maybe (NtfSubscription, NtfSubSMPAction, RcvQueue))
+
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
@@ -103,7 +124,12 @@ data RcvQueue = RcvQueue
     -- | sender queue ID
     sndId :: Maybe SMP.SenderId,
     -- | queue status
-    status :: QueueStatus
+    status :: QueueStatus,
+    -- | key pair to be used by the notification server to sign transmissions
+    ntfPublicKey :: Maybe NtfPublicVerifyKey,
+    ntfPrivateKey :: Maybe NtfPrivateSignKey,
+    -- | queue ID to be used by the notification server for NSUB command
+    notifierId :: Maybe NotifierId
   }
   deriving (Eq, Show)
 
@@ -183,7 +209,11 @@ instance Eq SomeConn where
 
 deriving instance Show SomeConn
 
-newtype ConnData = ConnData {connId :: ConnId}
+data ConnData = ConnData
+  { connId :: ConnId,
+    connAgentVersion :: Version,
+    duplexHandshake :: Maybe Bool -- added in agent protocol v2
+  }
   deriving (Eq, Show)
 
 -- * Confirmation types
@@ -230,30 +260,42 @@ type PrevRcvMsgHash = MsgHash
 -- | Corresponds to `last_snd_msg_hash` in `connections` table
 type PrevSndMsgHash = MsgHash
 
--- * Message data containers - used on Msg creation to reduce number of parameters
+-- * Message data containers
 
 data RcvMsgData = RcvMsgData
   { msgMeta :: MsgMeta,
     msgType :: AgentMessageType,
+    msgFlags :: MsgFlags,
     msgBody :: MsgBody,
     internalRcvId :: InternalRcvId,
     internalHash :: MsgHash,
     externalPrevSndHash :: MsgHash
   }
 
+data RcvMsg = RcvMsg
+  { internalId :: InternalId,
+    msgMeta :: MsgMeta,
+    msgBody :: MsgBody,
+    userAck :: Bool
+  }
+
 data SndMsgData = SndMsgData
   { internalId :: InternalId,
     internalSndId :: InternalSndId,
     internalTs :: InternalTs,
     msgType :: AgentMessageType,
+    msgFlags :: MsgFlags,
     msgBody :: MsgBody,
     internalHash :: MsgHash,
     prevMsgHash :: MsgHash
   }
 
-data PendingMsg = PendingMsg
-  { connId :: ConnId,
-    msgId :: InternalId
+data PendingMsgData = PendingMsgData
+  { msgId :: InternalId,
+    msgType :: AgentMessageType,
+    msgFlags :: MsgFlags,
+    msgBody :: MsgBody,
+    internalTs :: InternalTs
   }
   deriving (Show)
 
@@ -321,4 +363,6 @@ data StoreError
     SEX3dhKeysNotFound
   | -- | Used in `getMsg` that is not implemented/used. TODO remove.
     SENotImplemented
+  | -- | Used to wrap agent errors inside store operations to avoid race conditions
+    SEAgentError AgentErrorType
   deriving (Eq, Show, Exception)

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -19,6 +20,7 @@
 
 module Simplex.Messaging.Agent.Store.SQLite
   ( SQLiteStore (..),
+    AgentStoreMonad,
     createSQLiteStore,
     connectSQLiteStore,
     withConnection,
@@ -40,12 +42,12 @@ import Data.Char (toLower)
 import Data.Functor (($>))
 import Data.List (find, foldl', partition)
 import qualified Data.Map.Strict as M
-import Data.Maybe (listToMaybe)
+import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLError, ToRow, field)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLError, ToRow, field, (:.) (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.QQ (sql)
@@ -58,31 +60,35 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Client (NtfServer, NtfTknAction, NtfToken (..))
+import Simplex.Messaging.Notifications.Client (NtfServer, NtfSubAction, NtfSubOrSMPAction (..), NtfSubSMPAction, NtfSubscription (..), NtfTknAction, NtfToken (..))
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus (..), NtfTokenId)
 import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
-import Simplex.Messaging.Protocol (MsgBody, ProtocolServer (..))
+import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, ProtocolServer (..))
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util (bshow, liftIOEither)
+import Simplex.Messaging.Util (bshow, eitherToMaybe, liftIOEither)
+import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (takeDirectory)
 import System.IO (hFlush, stdout)
+import System.Posix.Files (stdFileMode)
+import System.Posix.Semaphore (OpenSemFlags (..), Semaphore, semOpen)
 import qualified UnliftIO.Exception as E
 
 -- * SQLite Store implementation
 
 data SQLiteStore = SQLiteStore
   { dbFilePath :: FilePath,
-    dbConnPool :: TBQueue DB.Connection,
+    dbConnection :: TMVar DB.Connection,
+    dbSemaphore :: Maybe Semaphore,
     dbNew :: Bool
   }
 
-createSQLiteStore :: FilePath -> Int -> [Migration] -> Bool -> IO SQLiteStore
-createSQLiteStore dbFilePath poolSize migrations yesToMigrations = do
+createSQLiteStore :: FilePath -> Maybe String -> [Migration] -> Bool -> IO SQLiteStore
+createSQLiteStore dbFilePath dbSemName_ migrations yesToMigrations = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing False dbDir
-  st <- connectSQLiteStore dbFilePath poolSize
+  st <- connectSQLiteStore dbFilePath dbSemName_
   checkThreadsafe st
   migrateSchema st migrations yesToMigrations
   pure st
@@ -118,13 +124,13 @@ confirmOrExit s = do
   ok <- getLine
   when (map toLower ok /= "y") exitFailure
 
-connectSQLiteStore :: FilePath -> Int -> IO SQLiteStore
-connectSQLiteStore dbFilePath poolSize = do
+connectSQLiteStore :: FilePath -> Maybe String -> IO SQLiteStore
+connectSQLiteStore dbFilePath dbSemName_ = do
   dbNew <- not <$> doesFileExist dbFilePath
-  dbConnPool <- newTBQueueIO $ toEnum poolSize
-  replicateM_ poolSize $
-    connectDB dbFilePath >>= atomically . writeTBQueue dbConnPool
-  pure SQLiteStore {dbFilePath, dbConnPool, dbNew}
+  dbConnection <- newTMVarIO =<< connectDB dbFilePath
+  -- let filemode = unionFileModes ownerReadMode ownerWriteMode
+  dbSemaphore <- forM dbSemName_ $ \name -> semOpen name OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 1
+  pure SQLiteStore {dbFilePath, dbConnection, dbSemaphore, dbNew}
 
 connectDB :: FilePath -> IO DB.Connection
 connectDB path = do
@@ -157,10 +163,10 @@ handleSQLError err e
   | otherwise = SEInternal $ bshow e
 
 withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withConnection SQLiteStore {dbConnPool} =
+withConnection SQLiteStore {dbConnection} =
   bracket
-    (atomically $ readTBQueue dbConnPool)
-    (atomically . writeTBQueue dbConnPool)
+    (atomically $ takeTMVar dbConnection)
+    (atomically . putTMVar dbConnection)
 
 withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
 withTransaction st action = withConnection st $ loop 100 100_000
@@ -187,19 +193,21 @@ createConn_ st gVar cData create =
       ConnData {connId = ""} -> createWithRandomId gVar $ create db
       ConnData {connId} -> create db connId $> Right connId
 
+type AgentStoreMonad m = (MonadUnliftIO m, MonadError StoreError m, MonadAgentStore SQLiteStore m)
+
 instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where
   createRcvConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
   createRcvConn st gVar cData q@RcvQueue {server} cMode =
     createConn_ st gVar cData $ \db connId -> do
       upsertServer_ db server
-      DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, cMode)
+      DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, cMode, connAgentVersion cData, duplexHandshake cData)
       insertRcvQueue_ db connId q
 
   createSndConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
   createSndConn st gVar cData q@SndQueue {server} =
     createConn_ st gVar cData $ \db connId -> do
       upsertServer_ db server
-      DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, SCMInvitation)
+      DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion cData, duplexHandshake cData)
       insertSndQueue_ db connId q
 
   getConn :: SQLiteStore -> ConnId -> m SomeConn
@@ -296,17 +304,47 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         |]
         [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
 
+  getRcvQueue :: SQLiteStore -> ConnId -> m RcvQueue
+  getRcvQueue st connId =
+    liftIOEither . withTransaction st $ \db -> do
+      rq_ <- getRcvQueueByConnId_ db connId
+      pure $ maybe (Left SEConnNotFound) Right rq_
+
+  setRcvQueueNotifierKey :: SQLiteStore -> ConnId -> NtfPublicVerifyKey -> NtfPrivateSignKey -> m ()
+  setRcvQueueNotifierKey st connId ntfPublicKey ntfPrivateKey =
+    liftIO . withTransaction st $ \db ->
+      DB.execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET ntf_public_key = ?, ntf_private_key = ?
+          WHERE conn_id = ?
+        |]
+        (ntfPublicKey, ntfPrivateKey, connId)
+
+  setRcvQueueNotifierId :: SQLiteStore -> ConnId -> NotifierId -> m ()
+  setRcvQueueNotifierId st connId nId =
+    liftIO . withTransaction st $ \db ->
+      DB.execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET ntf_id = ?
+          WHERE conn_id = ?
+        |]
+        (nId, connId)
+
   createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
-  createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}, ratchetState} =
+  createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues}, ratchetState} =
     liftIOEither . withTransaction st $ \db ->
       createWithRandomId gVar $ \confirmationId ->
         DB.execute
           db
           [sql|
             INSERT INTO conn_confirmations
-            (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, ?, 0);
+            (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, 0);
           |]
-          (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo)
+          (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues)
 
   acceptConfirmation :: SQLiteStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
   acceptConfirmation st confirmationId ownConnInfo =
@@ -326,17 +364,17 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         DB.query
           db
           [sql|
-            SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info
+            SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues
             FROM conn_confirmations
             WHERE confirmation_id = ?;
           |]
           (Only confirmationId)
     where
-      confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo) =
+      confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_) =
         AcceptedConfirmation
           { confirmationId,
             connId,
-            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
             ratchetState,
             ownConnInfo
           }
@@ -348,17 +386,17 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         DB.query
           db
           [sql|
-            SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, own_conn_info
+            SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, own_conn_info
             FROM conn_confirmations
             WHERE conn_id = ? AND accepted = 1;
           |]
           (Only connId)
     where
-      confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, ownConnInfo) =
+      confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_, ownConnInfo) =
         AcceptedConfirmation
           { confirmationId,
             connId,
-            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
             ratchetState,
             ownConnInfo
           }
@@ -374,6 +412,11 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         |]
         [":conn_id" := connId]
 
+  setHandshakeVersion :: SQLiteStore -> ConnId -> Version -> Bool -> m ()
+  setHandshakeVersion st connId aVersion duplexHS =
+    liftIO . withTransaction st $ \db ->
+      DB.execute db "UPDATE connections SET smp_agent_version = ?, duplex_handshake = ? WHERE conn_id = ?" (aVersion, duplexHS, connId)
+
   createInvitation :: SQLiteStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
   createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =
     liftIOEither . withTransaction st $ \db ->
@@ -459,22 +502,25 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
       insertSndMsgDetails_ db connId sndMsgData
       updateHashSnd_ db connId sndMsgData
 
-  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
+  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, PendingMsgData)
   getPendingMsgData st connId msgId =
     liftIOEither . withTransaction st $ \db -> runExceptT $ do
       rq_ <- liftIO $ getRcvQueueByConnId_ db connId
       msgData <-
-        ExceptT . firstRow id SEMsgNotFound $
+        ExceptT . firstRow pendingMsgData SEMsgNotFound $
           DB.query
             db
             [sql|
-                SELECT m.msg_type, m.msg_body, m.internal_ts
+                SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts
                 FROM messages m
                 JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
                 WHERE m.conn_id = ? AND m.internal_id = ?
               |]
             (connId, msgId)
       pure (rq_, msgData)
+    where
+      pendingMsgData :: (AgentMessageType, MsgFlags, MsgBody, InternalTs) -> PendingMsgData
+      pendingMsgData (msgType, msgFlags, msgBody, internalTs) = PendingMsgData {msgId, msgType, msgFlags, msgBody, internalTs}
 
   getPendingMsgs :: SQLiteStore -> ConnId -> m [InternalId]
   getPendingMsgs st connId =
@@ -482,21 +528,33 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
       map fromOnly
         <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)
 
-  checkRcvMsg :: SQLiteStore -> ConnId -> InternalId -> m ()
-  checkRcvMsg st connId msgId =
-    liftIOEither . withTransaction st $ \db ->
-      hasMsg
+  setMsgUserAck :: SQLiteStore -> ConnId -> InternalId -> m SMP.MsgId
+  setMsgUserAck st connId agentMsgId =
+    liftIOEither . withTransaction st $ \db -> do
+      DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId)
+      firstRow fromOnly SEMsgNotFound $
+        DB.query db "SELECT broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
+
+  getLastMsg :: SQLiteStore -> ConnId -> SMP.MsgId -> m (Maybe RcvMsg)
+  getLastMsg st connId msgId =
+    liftIO . withTransaction st $ \db ->
+      fmap rcvMsg . listToMaybe
         <$> DB.query
           db
           [sql|
-            SELECT conn_id, internal_id
-            FROM rcv_messages
-            WHERE conn_id = ? AND internal_id = ?
+            SELECT
+              r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity,
+              m.msg_body, r.user_ack
+            FROM rcv_messages r
+            JOIN messages m ON r.internal_id = m.internal_id
+            JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id
+            WHERE r.conn_id = ? AND r.broker_id = ?
           |]
           (connId, msgId)
     where
-      hasMsg :: [(ConnId, InternalId)] -> Either StoreError ()
-      hasMsg r = if null r then Left SEMsgNotFound else Right ()
+      rcvMsg (agentMsgId, internalTs, brokerId, brokerTs, sndMsgId, integrity, msgBody, userAck) =
+        let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
+         in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgBody, userAck}
 
   deleteMsg :: SQLiteStore -> ConnId -> InternalId -> m ()
   deleteMsg st connId msgId =
@@ -587,16 +645,16 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
             db
             [sql|
               SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
-                t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, t.tkn_status, t.tkn_action
+                t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, t.tkn_status, t.tkn_action
               FROM ntf_tokens t
               JOIN ntf_servers s USING (ntf_host, ntf_port)
             |]
       pure . first listToMaybe $ partition ((t ==) . deviceToken) tokens
     where
-      ntfToken (host, port, keyHash, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction) =
+      ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction)) =
         let ntfServer = ProtocolServer {host, port, keyHash}
             ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
-         in NtfToken {deviceToken = t, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction}
+         in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction}
 
   updateNtfTokenRegistration :: SQLiteStore -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
   updateNtfTokenRegistration st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret =
@@ -635,6 +693,150 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
         |]
         (provider, token, host, port)
 
+  getNtfSubscription :: SQLiteStore -> ConnId -> m (Maybe NtfSubscription)
+  getNtfSubscription st connId =
+    liftIO . withTransaction st $ \db ->
+      maybeFirstRow ntfSubscription $
+        DB.query
+          db
+          [sql|
+            SELECT s.host, s.port, s.key_hash, ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
+              nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action_ts
+            FROM ntf_subscriptions nsb
+            JOIN servers s ON s.host = nsb.smp_host AND s.port = nsb.smp_port
+            JOIN ntf_servers ns USING (ntf_host, ntf_port)
+            WHERE nsb.conn_id = ?
+          |]
+          (Only connId)
+    where
+      ntfSubscription (smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, ntfSubActionTs) =
+        let smpServer = SMPServer smpHost smpPort smpKeyHash
+            ntfServer = ProtocolServer ntfHost ntfPort ntfKeyHash
+         in NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus, ntfSubActionTs}
+
+  createNtfSubscription :: SQLiteStore -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  createNtfSubscription st NtfSubscription {connId, smpServer = (SMPServer host port _), ntfQueueId, ntfServer = (SMPServer ntfHost ntfPort _), ntfSubId, ntfSubStatus, ntfSubActionTs} ntfAction =
+    liftIO . withTransaction st $ \db ->
+      DB.execute
+        db
+        [sql|
+          INSERT INTO ntf_subscriptions
+            (conn_id, smp_host, smp_port, smp_ntf_id, ntf_host, ntf_port, ntf_sub_id,
+             ntf_sub_status, ntf_sub_action, ntf_sub_smp_action, ntf_sub_action_ts)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?)
+        |]
+        ( (connId, host, port, ntfQueueId, ntfHost, ntfPort, ntfSubId)
+            :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ntfSubActionTs)
+        )
+    where
+      (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction ntfAction
+
+  markNtfSubscriptionForDeletion :: SQLiteStore -> ConnId -> m ()
+  markNtfSubscriptionForDeletion _st _rcvQueue = throwError SENotImplemented
+
+  updateNtfSubscription :: SQLiteStore -> ConnId -> NtfSubscription -> NtfSubOrSMPAction -> m ()
+  updateNtfSubscription st connId NtfSubscription {ntfQueueId, ntfSubId, ntfSubStatus, ntfSubActionTs} ntfAction =
+    liftIO . withTransaction st $ \db -> do
+      r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
+      forM_ r $ \updatedBySupervisor -> do
+        updatedAt <- getCurrentTime
+        if updatedBySupervisor
+          then
+            DB.execute
+              db
+              [sql|
+                UPDATE ntf_subscriptions
+                SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ?
+                WHERE conn_id = ?
+              |]
+              (ntfQueueId, ntfSubId, ntfSubStatus, False, updatedAt, connId)
+          else
+            DB.execute
+              db
+              [sql|
+                UPDATE ntf_subscriptions
+                SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
+                WHERE conn_id = ?
+              |]
+              (ntfQueueId, ntfSubId, ntfSubStatus, ntfSubAction, ntfSubSMPAction, ntfSubActionTs, False, updatedAt, connId)
+    where
+      (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction ntfAction
+
+  setNullNtfSubscriptionAction :: SQLiteStore -> ConnId -> m ()
+  setNullNtfSubscriptionAction st connId =
+    liftIO . withTransaction st $ \db -> do
+      r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
+      forM_ r $ \updatedBySupervisor ->
+        unless updatedBySupervisor $ do
+          updatedAt <- getCurrentTime
+          DB.execute
+            db
+            [sql|
+              UPDATE ntf_subscriptions
+              SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
+              WHERE conn_id = ?
+            |]
+            (Nothing :: Maybe NtfSubAction, Nothing :: Maybe NtfSubSMPAction, Nothing :: Maybe UTCTime, False, updatedAt, connId)
+
+  deleteNtfSubscription :: SQLiteStore -> ConnId -> m ()
+  deleteNtfSubscription _st _connId = throwError SENotImplemented
+
+  getNextNtfSubAction :: SQLiteStore -> NtfServer -> m (Maybe (NtfSubscription, NtfSubAction, RcvQueue))
+  getNextNtfSubAction st ntfServer@(ProtocolServer ntfHost ntfPort _) =
+    liftIO . withTransaction st $ \db -> do
+      r <-
+        maybeFirstRow ntfSubscription $
+          DB.query
+            db
+            [sql|
+              SELECT ns.conn_id, s.host, s.port, s.key_hash,
+                ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action
+              FROM ntf_subscriptions ns
+              JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port
+              WHERE ns.ntf_host = ? AND ns.ntf_port = ? AND ns.ntf_sub_action IS NOT NULL
+              ORDER BY ns.ntf_sub_action_ts ASC
+              LIMIT 1
+            |]
+            (ntfHost, ntfPort)
+      case r of
+        Just (ntfSub@NtfSubscription {connId}, ntfSubAction) -> do
+          DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = ? WHERE conn_id = ?" (False, connId)
+          rq_ <- getRcvQueueByConnId_ db connId
+          pure $ (\rq -> Just (ntfSub, ntfSubAction, rq)) =<< rq_
+        Nothing -> pure Nothing
+    where
+      ntfSubscription (connId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, ntfSubActionTs, ntfSubAction) =
+        let smpServer = SMPServer smpHost smpPort smpKeyHash
+         in (NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus, ntfSubActionTs}, ntfSubAction)
+
+  getNextNtfSubSMPAction :: SQLiteStore -> SMPServer -> m (Maybe (NtfSubscription, NtfSubSMPAction, RcvQueue))
+  getNextNtfSubSMPAction st smpServer@(SMPServer smpHost smpPort _) =
+    liftIO . withTransaction st $ \db -> do
+      r <-
+        maybeFirstRow ntfSubscription $
+          DB.query
+            db
+            [sql|
+              SELECT ns.conn_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
+                ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
+              FROM ntf_subscriptions ns
+              JOIN ntf_servers s USING (ntf_host, ntf_port)
+              WHERE ns.smp_host = ? AND ns.smp_port = ? AND ns.ntf_sub_smp_action IS NOT NULL
+              ORDER BY ns.ntf_sub_action_ts ASC
+              LIMIT 1
+            |]
+            (smpHost, smpPort)
+      case r of
+        Just (ntfSub@NtfSubscription {connId}, ntfSubAction) -> do
+          DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = ? WHERE conn_id = ?" (False, connId)
+          rq_ <- getRcvQueueByConnId_ db connId
+          pure $ (\rq -> Just (ntfSub, ntfSubAction, rq)) =<< rq_
+        Nothing -> pure Nothing
+    where
+      ntfSubscription (connId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, ntfSubActionTs, ntfSubAction) =
+        let ntfServer = ProtocolServer ntfHost ntfPort ntfKeyHash
+         in (NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus, ntfSubActionTs}, ntfSubAction)
+
 -- * Auxiliary helpers
 
 instance ToField QueueStatus where toField = toField . serializeQueueStatus
@@ -681,6 +883,14 @@ instance ToField (SConnectionMode c) where toField = toField . connMode
 
 instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT
 
+instance ToField MsgFlags where toField = toField . decodeLatin1 . smpEncode
+
+instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
+
+instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList
+
+instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -688,6 +898,13 @@ listToEither e _ = Left e
 firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
 firstRow f e a = second f . listToEither e <$> a
 
+maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b)
+maybeFirstRow f q = fmap f . listToMaybe <$> q
+
+-- TODO move from simplex-chat
+-- firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
+-- firstRow' f e a = (f <=< listToEither e) <$> a
+
 {- ORMOLU_DISABLE -}
 -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
@@ -787,29 +1004,29 @@ getConn_ dbConn connId =
 getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
 getConnData_ dbConn connId' =
   connData
-    <$> DB.query dbConn "SELECT conn_id, conn_mode FROM connections WHERE conn_id = ?;" (Only connId')
+    <$> DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, duplex_handshake FROM connections WHERE conn_id = ?;" (Only connId')
   where
-    connData [(connId, cMode)] = Just (ConnData {connId}, cMode)
+    connData [(connId, cMode, connAgentVersion, duplexHandshake)] = Just (ConnData {connId, connAgentVersion, duplexHandshake}, cMode)
     connData _ = Nothing
 
 getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
 getRcvQueueByConnId_ dbConn connId =
-  rcvQueue
+  listToMaybe . map rcvQueue
     <$> DB.query
       dbConn
       [sql|
         SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
-          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status
+          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
+          q.ntf_public_key, q.ntf_private_key, q.ntf_id
         FROM rcv_queues q
         INNER JOIN servers s ON q.host = s.host AND q.port = s.port
         WHERE q.conn_id = ?;
       |]
       (Only connId)
   where
-    rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)] =
+    rcvQueue ((keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (ntfPublicKey, ntfPrivateKey, notifierId)) =
       let server = SMPServer host port keyHash
-       in Just RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status}
-    rcvQueue _ = Nothing
+       in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, ntfPublicKey, ntfPrivateKey, notifierId}
 
 getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
 getSndQueueByConnId_ dbConn connId =
@@ -862,21 +1079,22 @@ updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId =
 -- * createRcvMsg helpers
 
 insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
-insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgBody, internalRcvId} = do
+insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId} = do
   let MsgMeta {recipient = (internalId, internalTs)} = msgMeta
   DB.executeNamed
     dbConn
     [sql|
       INSERT INTO messages
-        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
       VALUES
-        (:conn_id,:internal_id,:internal_ts,:internal_rcv_id,            NULL,:msg_type, :msg_body);
+        (:conn_id,:internal_id,:internal_ts,:internal_rcv_id,            NULL,:msg_type,:msg_flags,:msg_body);
     |]
     [ ":conn_id" := connId,
       ":internal_id" := internalId,
       ":internal_ts" := internalTs,
       ":internal_rcv_id" := internalRcvId,
       ":msg_type" := msgType,
+      ":msg_flags" := msgFlags,
       ":msg_body" := msgBody
     ]
 
@@ -962,15 +1180,16 @@ insertSndMsgBase_ dbConn connId SndMsgData {..} = do
     dbConn
     [sql|
       INSERT INTO messages
-        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
       VALUES
-        (:conn_id,:internal_id,:internal_ts,            NULL,:internal_snd_id,:msg_type, :msg_body);
+        (:conn_id,:internal_id,:internal_ts,            NULL,:internal_snd_id,:msg_type,:msg_flags,:msg_body);
     |]
     [ ":conn_id" := connId,
       ":internal_id" := internalId,
       ":internal_ts" := internalTs,
       ":internal_snd_id" := internalSndId,
       ":msg_type" := msgType,
+      ":msg_flags" := msgFlags,
       ":msg_body" := msgBody
     ]
 
@@ -1023,3 +1242,7 @@ createWithRandomId gVar create = tryCreate 3
 
 randomId :: TVar ChaChaDRG -> Int -> IO ByteString
 randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
+
+ntfSubAndSMPAction :: NtfSubOrSMPAction -> (Maybe NtfSubAction, Maybe NtfSubSMPAction)
+ntfSubAndSMPAction (NtfSubAction nsa) = (Just nsa, Nothing)
+ntfSubAndSMPAction (NtfSubSMPAction nsa) = (Nothing, Just nsa)

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

@@ -27,6 +27,7 @@ import qualified Database.SQLite3 as SQLite3
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
@@ -35,7 +36,8 @@ schemaMigrations :: [(String, Query)]
 schemaMigrations =
   [ ("20220101_initial", m20220101_initial),
     ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
-    ("20220322_notifications", m20220322_notifications)
+    ("20220322_notifications", m20220322_notifications),
+    ("20220607_v2", m20220608_v2)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -19,7 +19,7 @@ CREATE TABLE ntf_servers (
 
 CREATE TABLE ntf_tokens (
   provider TEXT NOT NULL, -- apn
-  device_token TEXT NOT NULL,
+  device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
   ntf_host TEXT NOT NULL,
   ntf_port TEXT NOT NULL,
   tkn_id BLOB, -- token ID assigned by notifications server

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

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

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

@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220608_v2 :: Query
+m20220608_v2 =
+  [sql|
+ALTER TABLE messages ADD COLUMN msg_flags TEXT NULL;
+
+ALTER TABLE conn_confirmations ADD COLUMN smp_reply_queues BLOB NULL;
+
+ALTER TABLE connections ADD COLUMN duplex_handshake INTEGER NULL DEFAULT 0;
+
+ALTER TABLE rcv_messages ADD COLUMN user_ack INTEGER NULL DEFAULT 0;
+
+ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
+
+ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
+
+ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
+
+CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
+
+CREATE TABLE ntf_subscriptions (
+  conn_id BLOB NOT NULL, -- ? make nullable for when connection is deleted but we still need to delete subscription
+  smp_host TEXT NULL,
+  smp_port TEXT NULL,
+  smp_ntf_id BLOB,
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_sub_id BLOB,
+  ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubAction
+  ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can (should) be not null in same record
+  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
+  updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command (state still should be updated)
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
+  PRIMARY KEY (conn_id),
+  -- FOREIGN KEY (conn_id) REFERENCES connections
+  --   ON DELETE SET NULL ON UPDATE CASCADE,
+  FOREIGN KEY (smp_host, smp_port) REFERENCES servers (host, port)
+    ON DELETE SET NULL ON UPDATE CASCADE,
+  FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
+    ON DELETE RESTRICT ON UPDATE CASCADE
+) WITHOUT ROWID;
+|]

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

@@ -19,6 +19,8 @@ CREATE TABLE connections(
   last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',
   last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
   smp_agent_version INTEGER NOT NULL DEFAULT 1
+  ,
+  duplex_handshake INTEGER NULL DEFAULT 0
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -34,6 +36,9 @@ CREATE TABLE rcv_queues(
   status TEXT NOT NULL,
   smp_server_version INTEGER NOT NULL DEFAULT 1,
   smp_client_version INTEGER,
+  ntf_public_key BLOB,
+  ntf_private_key BLOB,
+  ntf_id BLOB,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -64,6 +69,7 @@ CREATE TABLE messages(
   internal_snd_id INTEGER,
   msg_type BLOB NOT NULL, --(H)ELLO,(R)EPLY,(D)ELETE. Should SMP confirmation be saved too?
   msg_body BLOB NOT NULL DEFAULT x'',
+  msg_flags TEXT NULL,
   PRIMARY KEY(conn_id, internal_id),
   FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
   ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
@@ -80,6 +86,7 @@ CREATE TABLE rcv_messages(
   internal_hash BLOB NOT NULL,
   external_prev_snd_hash BLOB NOT NULL,
   integrity BLOB NOT NULL,
+  user_ack INTEGER NULL DEFAULT 0,
   PRIMARY KEY(conn_id, internal_rcv_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -104,6 +111,8 @@ CREATE TABLE conn_confirmations(
   accepted INTEGER NOT NULL,
   own_conn_info BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now'))
+  ,
+  smp_reply_queues BLOB NULL
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
@@ -142,7 +151,7 @@ CREATE TABLE ntf_servers(
 ) WITHOUT ROWID;
 CREATE TABLE ntf_tokens(
   provider TEXT NOT NULL, -- apn
-  device_token TEXT NOT NULL,
+  device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
   ntf_host TEXT NOT NULL,
   ntf_port TEXT NOT NULL,
   tkn_id BLOB, -- token ID assigned by notifications server
@@ -159,3 +168,27 @@ tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
+CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
+CREATE TABLE ntf_subscriptions(
+  conn_id BLOB NOT NULL, -- ? make nullable for when connection is deleted but we still need to delete subscription
+  smp_host TEXT NULL,
+  smp_port TEXT NULL,
+  smp_ntf_id BLOB,
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_sub_id BLOB,
+  ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubAction
+  ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can(should) be not null in same record
+  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
+  updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  PRIMARY KEY(conn_id),
+  -- FOREIGN KEY(conn_id) REFERENCES connections
+  -- ON DELETE SET NULL ON UPDATE CASCADE,
+  FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
+  ON DELETE SET NULL ON UPDATE CASCADE,
+  FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+) WITHOUT ROWID;

src/Simplex/Messaging/Client.hs

@@ -32,6 +32,7 @@ module Simplex.Messaging.Client
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
+    getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
@@ -70,6 +71,7 @@ import Simplex.Messaging.Transport.Client (runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
+import Simplex.Messaging.Version
 import System.Timeout (timeout)
 
 -- | 'SMPClient' is a handle used to send commands to a specific SMP server.
@@ -79,6 +81,7 @@ data ProtocolClient msg = ProtocolClient
   { action :: Async (),
     connected :: TVar Bool,
     sessionId :: SessionId,
+    thVersion :: Version,
     protocolServer :: ProtocolServer,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
@@ -104,7 +107,9 @@ data ProtocolClientConfig = ProtocolClientConfig
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
     -- | period for SMP ping commands (microseconds)
-    smpPing :: Int
+    smpPing :: Int,
+    -- | SMP client-server protocol version range
+    smpServerVRange :: VersionRange
   }
 
 -- | Default protocol client configuration.
@@ -115,7 +120,8 @@ defaultClientConfig =
       defaultTransport = ("443", transport @TLS),
       tcpTimeout = 5_000_000,
       tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPing = 600_000_000 -- 10min
+      smpPing = 600_000_000, -- 10min
+      smpServerVRange = supportedSMPServerVRange
     }
 
 data Request msg = Request
@@ -131,7 +137,7 @@ type Response msg = Either ProtocolClientError msg
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall msg. Protocol msg => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
   (atomically mkProtocolClient >>= runClient useTransport)
     `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
   where
@@ -146,6 +152,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
         ProtocolClient
           { action = undefined,
             sessionId = undefined,
+            thVersion = undefined,
             connected,
             protocolServer,
             tcpTimeout,
@@ -165,7 +172,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
             `finally` atomically (putTMVar thVar $ Left PCENetworkError)
       th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of
-        Just (Right THandle {sessionId}) -> Right c {action, sessionId}
+        Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
         Just (Left e) -> Left e
         Nothing -> Left PCENetworkError
 
@@ -177,13 +184,13 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
 
     client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
     client _ c thVar h =
-      runExceptT (protocolClientHandshake @msg h $ keyHash protocolServer) >>= \case
+      runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
         Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
-        Right th@THandle {sessionId} -> do
+        Right th@THandle {sessionId, thVersion} -> do
           atomically $ do
             writeTVar (connected c) True
             putTMVar thVar $ Right th
-          let c' = c {sessionId} :: ProtocolClient msg
+          let c' = c {sessionId, thVersion} :: ProtocolClient msg
           -- TODO remove ping if 0 is passed (or Nothing?)
           raceAny_ [send c' th, process c', receive c' th, ping c']
             `finally` disconnected
@@ -281,6 +288,18 @@ subscribeSMPQueue c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
       lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
     _ -> throwE PCEUnexpectedResponse
 
+-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
+--
+-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
+getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe (MsgId, MsgFlags))
+getSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+  sendSMPCommand c (Just rpKey) rId GET >>= \case
+    OK -> pure Nothing
+    cmd@(MSG msgId _ msgFlags _) -> do
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+      pure $ Just (msgId, msgFlags)
+    _ -> throwE PCEUnexpectedResponse
+
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
@@ -305,18 +324,18 @@ enableSMPQueueNotifications c rpKey rId notifierKey =
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT ProtocolClientError IO ()
-sendSMPMessage c spKey sId msg =
-  sendSMPCommand c spKey sId (SEND msg) >>= \case
+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT ProtocolClientError IO ()
+sendSMPMessage c spKey sId flags msg =
+  sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
     _ -> throwE PCEUnexpectedResponse
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
-ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
-  sendSMPCommand c (Just rpKey) rId ACK >>= \case
+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
+ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId msgId =
+  sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
     cmd@MSG {} ->
       lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
@@ -347,9 +366,9 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
 -- | Send Protocol command
 sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
+sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
   corrId <- lift_ getNextCorrId
-  t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
+  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
   ExceptT $ sendRecv corrId t
   where
     lift_ :: STM a -> ExceptT ProtocolClientError IO a

src/Simplex/Messaging/Crypto.hs

@@ -678,7 +678,9 @@ data CryptoError
     CERatchetHeader
   | -- | too many skipped messages
     CERatchetTooManySkipped
-  | -- | duplicate message number (or, possibly, skipped message that failed to decrypt?)
+  | -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
+    CERatchetEarlierMessage
+  | -- | duplicate message number
     CERatchetDuplicateMessage
   deriving (Eq, Show, Exception)
 

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -416,7 +416,8 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
     skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
     skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
     skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
-      | rcNr > untilN = Left CERatchetDuplicateMessage
+      | rcNr > untilN + 1 = Left CERatchetEarlierMessage
+      | rcNr == untilN + 1 = Left CERatchetDuplicateMessage
       | rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
       | rcNr == untilN = Right (r, M.empty)
       | otherwise =

src/Simplex/Messaging/Encoding.hs

@@ -47,66 +47,100 @@ class Encoding a where
 
 instance Encoding Char where
   smpEncode = B.singleton
+  {-# INLINE smpEncode #-}
   smpP = A.anyChar
+  {-# INLINE smpP #-}
+
+instance Encoding Bool where
+  smpEncode = \case
+    True -> "T"
+    False -> "F"
+  {-# INLINE smpEncode #-}
+  smpP =
+    smpP >>= \case
+      'T' -> pure True
+      'F' -> pure False
+      _ -> fail "invalid Bool"
+  {-# INLINE smpP #-}
 
 instance Encoding Word16 where
   smpEncode = encodeWord16
+  {-# INLINE smpEncode #-}
   smpP = decodeWord16 <$> A.take 2
+  {-# INLINE smpP #-}
 
 instance Encoding Word32 where
   smpEncode = encodeWord32
+  {-# INLINE smpEncode #-}
   smpP = decodeWord32 <$> A.take 4
+  {-# INLINE smpP #-}
 
 instance Encoding Int64 where
   smpEncode i = w32 (i `shiftR` 32) <> w32 i
+  {-# INLINE smpEncode #-}
   smpP = do
     l <- w32P
     r <- w32P
     pure $ (l `shiftL` 32) .|. r
+  {-# INLINE smpP #-}
 
 w32 :: Int64 -> ByteString
 w32 = smpEncode @Word32 . fromIntegral
+{-# INLINE w32 #-}
 
 w32P :: Parser Int64
 w32P = fromIntegral <$> smpP @Word32
+{-# INLINE w32P #-}
 
 -- ByteStrings are assumed no longer than 255 bytes
 instance Encoding ByteString where
   smpEncode s = B.cons (lenEncode $ B.length s) s
+  {-# INLINE smpEncode #-}
   smpP = A.take =<< lenP
+  {-# INLINE smpP #-}
 
 lenEncode :: Int -> Char
 lenEncode = w2c . fromIntegral
+{-# INLINE lenEncode #-}
 
 lenP :: Parser Int
 lenP = fromIntegral . c2w <$> A.anyChar
+{-# INLINE lenP #-}
 
 instance Encoding a => Encoding (Maybe a) where
   smpEncode s = maybe "0" (("1" <>) . smpEncode) s
+  {-# INLINE smpEncode #-}
   smpP =
     smpP >>= \case
       '0' -> pure Nothing
       '1' -> Just <$> smpP
       _ -> fail "invalid Maybe tag"
+  {-# INLINE smpP #-}
 
 newtype Tail = Tail {unTail :: ByteString}
 
 instance Encoding Tail where
   smpEncode = unTail
+  {-# INLINE smpEncode #-}
   smpP = Tail <$> A.takeByteString
+  {-# INLINE smpP #-}
 
 -- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix
 newtype Large = Large {unLarge :: ByteString}
 
 instance Encoding Large where
   smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s
+  {-# INLINE smpEncode #-}
   smpP = do
     len <- fromIntegral <$> smpP @Word16
     Large <$> A.take len
+  {-# INLINE smpP #-}
 
 instance Encoding SystemTime where
   smpEncode = smpEncode . systemSeconds
+  {-# INLINE smpEncode #-}
   smpP = MkSystemTime <$> smpP <*> pure 0
+  {-# INLINE smpP #-}
 
 -- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
 smpEncodeList :: Encoding a => [a] -> ByteString
@@ -117,7 +151,9 @@ smpListP = (`A.count` smpP) =<< lenP
 
 instance Encoding String where
   smpEncode = smpEncode . B.pack
+  {-# INLINE smpEncode #-}
   smpP = B.unpack <$> smpP
+  {-# INLINE smpP #-}
 
 instance Encoding a => Encoding (L.NonEmpty a) where
   smpEncode = smpEncodeList . L.toList
@@ -128,20 +164,36 @@ instance Encoding a => Encoding (L.NonEmpty a) where
 
 instance (Encoding a, Encoding b) => Encoding (a, b) where
   smpEncode (a, b) = smpEncode a <> smpEncode b
+  {-# INLINE smpEncode #-}
   smpP = (,) <$> smpP <*> smpP
+  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
   smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
+  {-# INLINE smpEncode #-}
   smpP = (,,) <$> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
   smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d
+  {-# INLINE smpEncode #-}
   smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
   smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
+  {-# INLINE smpEncode #-}
   smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
   smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
+  {-# INLINE smpEncode #-}
   smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}
+
+instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
+  smpEncode (a, b, c, d, e, f, g) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g
+  {-# INLINE smpEncode #-}
+  smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}

src/Simplex/Messaging/Encoding/String.hs

@@ -26,10 +26,13 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
+import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Time.Clock.System (SystemTime (..))
 import Data.Word (Word16)
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))
 
@@ -76,11 +79,35 @@ instance FromJSON Str where
 
 instance StrEncoding a => StrEncoding (Maybe a) where
   strEncode = maybe "" strEncode
+  {-# INLINE strEncode #-}
   strP = optional strP
+  {-# INLINE strP #-}
 
 instance StrEncoding Word16 where
   strEncode = B.pack . show
+  {-# INLINE strEncode #-}
   strP = A.decimal
+  {-# INLINE strP #-}
+
+instance StrEncoding Char where
+  strEncode = smpEncode
+  {-# INLINE strEncode #-}
+  strP = strP
+  {-# INLINE strP #-}
+
+instance StrEncoding Bool where
+  strEncode = smpEncode
+  {-# INLINE strEncode #-}
+  strP = smpP
+  {-# INLINE strP #-}
+
+instance StrEncoding Int64 where
+  strEncode = B.pack . show
+  strP = A.decimal
+
+instance StrEncoding SystemTime where
+  strEncode = strEncode . systemSeconds
+  strP = MkSystemTime <$> strP <*> pure 0
 
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
@@ -99,19 +126,27 @@ listItem = parseAll strP <$?> A.takeTill (== ',')
 
 instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
   strEncode (a, b) = B.unwords [strEncode a, strEncode b]
+  {-# INLINE strEncode #-}
   strP = (,) <$> strP_ <*> strP
+  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c) => StrEncoding (a, b, c) where
   strEncode (a, b, c) = B.unwords [strEncode a, strEncode b, strEncode c]
+  {-# INLINE strEncode #-}
   strP = (,,) <$> strP_ <*> strP_ <*> strP
+  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d) => StrEncoding (a, b, c, d) where
   strEncode (a, b, c, d) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d]
+  {-# INLINE strEncode #-}
   strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP
+  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e) => StrEncoding (a, b, c, d, e) where
   strEncode (a, b, c, d, e) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e]
+  {-# INLINE strEncode #-}
   strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
+  {-# INLINE strP #-}
 
 strP_ :: StrEncoding a => Parser a
 strP_ = strP <* A.space

src/Simplex/Messaging/Notifications/Client.hs

@@ -10,15 +10,18 @@ module Simplex.Messaging.Notifications.Client where
 import Control.Monad.Except
 import Control.Monad.Trans.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Time (UTCTime)
 import Data.Word (Word16)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Protocol (ConnId)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (blobFieldDecoder)
-import Simplex.Messaging.Protocol (ProtocolServer)
+import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Protocol (NotifierId, ProtocolServer, SMPServer)
 
 type NtfServer = ProtocolServer
 
@@ -27,7 +30,7 @@ type NtfClient = ProtocolClient NtfResponse
 ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
 ntfRegisterToken c pKey newTkn =
   sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
-    NRId tknId dhKey -> pure (tknId, dhKey)
+    NRTknId tknId dhKey -> pure (tknId, dhKey)
     _ -> throwE PCEUnexpectedResponse
 
 ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
@@ -45,10 +48,10 @@ ntfDeleteToken = okNtfCommand TDEL
 ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
 ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
-ntfCreateSubsciption :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO (NtfSubscriptionId, C.PublicKeyX25519)
-ntfCreateSubsciption c pKey newSub =
+ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO NtfSubscriptionId
+ntfCreateSubscription c pKey newSub =
   sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
-    NRId tknId dhKey -> pure (tknId, dhKey)
+    NRSubId subId -> pure subId
     _ -> throwE PCEUnexpectedResponse
 
 ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
@@ -130,3 +133,97 @@ newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys =
       ntfTknStatus = NTNew,
       ntfTknAction = Just NTARegister
     }
+
+data NtfSubOrSMPAction = NtfSubAction NtfSubAction | NtfSubSMPAction NtfSubSMPAction
+
+data NtfSubAction
+  = NSACreate
+  | NSACheck
+  | NSADelete
+  deriving (Show)
+
+instance Encoding NtfSubAction where
+  smpEncode = \case
+    NSACreate -> "N"
+    NSACheck -> "C"
+    NSADelete -> "D"
+  smpP =
+    A.anyChar >>= \case
+      'N' -> pure NSACreate
+      'C' -> pure NSACheck
+      'D' -> pure NSADelete
+      _ -> fail "bad NtfSubAction"
+
+instance FromField NtfSubAction where fromField = blobFieldDecoder smpDecode
+
+instance ToField NtfSubAction where toField = toField . smpEncode
+
+data NtfSubSMPAction
+  = NSAKey
+  deriving (Show)
+
+instance Encoding NtfSubSMPAction where
+  smpEncode = \case
+    NSAKey -> "K"
+  smpP =
+    A.anyChar >>= \case
+      'K' -> pure NSAKey
+      _ -> fail "bad NtfSubSMPAction"
+
+instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
+
+instance ToField NtfSubSMPAction where toField = toField . smpEncode
+
+data NtfAgentSubStatus
+  = -- | subscription started
+    NASNew
+  | -- | state after NKEY - notifier ID is assigned to queue on SMP server
+    NASKey
+  | -- | state after SNEW - subscription created on notification server
+    NASCreated NtfSubStatus
+  | -- | state after SDEL (subscription is deleted on notification server)
+    NASDeleted
+  deriving (Eq, Show)
+
+instance Encoding NtfAgentSubStatus where
+  smpEncode = \case
+    NASNew -> "NEW"
+    NASKey -> "KEY"
+    NASCreated status -> "CREATED " <> smpEncode status
+    NASDeleted -> "DELETED"
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "NEW" -> pure NASNew
+      "KEY" -> pure NASKey
+      "CREATED" -> do
+        _ <- A.space
+        NASCreated <$> smpP
+      "DELETED" -> pure NASDeleted
+      _ -> fail "bad NtfAgentSubStatus"
+
+instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
+
+instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
+
+data NtfSubscription = NtfSubscription
+  { connId :: ConnId,
+    smpServer :: SMPServer,
+    ntfQueueId :: Maybe NotifierId,
+    ntfServer :: NtfServer,
+    ntfSubId :: Maybe NtfSubscriptionId,
+    ntfSubStatus :: NtfAgentSubStatus,
+    ntfSubActionTs :: UTCTime
+  }
+  deriving (Show)
+
+newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> UTCTime -> NtfSubscription
+newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus ntfSubActionTs =
+  NtfSubscription
+    { connId,
+      smpServer,
+      ntfQueueId,
+      ntfServer,
+      ntfSubId = Nothing,
+      ntfSubStatus,
+      ntfSubActionTs
+    }

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -120,16 +120,18 @@ instance ToJSON NtfRegCode where
 
 data NewNtfEntity (e :: NtfEntity) where
   NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
-  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NewNtfEntity 'Subscription
+  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription
 
 deriving instance Show (NewNtfEntity e)
 
 data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
 
+deriving instance Show ANewNtfEntity
+
 instance NtfEntityI e => Encoding (NewNtfEntity e) where
   smpEncode = \case
     NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
-    NewNtfSub tknId smpQueue -> smpEncode ('S', tknId, smpQueue)
+    NewNtfSub tknId smpQueue notifierKey -> smpEncode ('S', tknId, smpQueue, notifierKey)
   smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
 
 instance Encoding ANewNtfEntity where
@@ -137,7 +139,7 @@ instance Encoding ANewNtfEntity where
   smpP =
     A.anyChar >>= \case
       'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
-      'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP)
+      'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP <*> smpP)
       _ -> fail "bad ANewNtfEntity"
 
 instance Protocol NtfResponse where
@@ -161,7 +163,7 @@ data NtfCommand (e :: NtfEntity) where
   TCRN :: Word16 -> NtfCommand 'Token
   -- | create SMP subscription
   SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
-  -- | check SMP subscription status (response is STAT)
+  -- | check SMP subscription status (response is SUB)
   SCHK :: NtfCommand 'Subscription
   -- | delete SMP subscription
   SDEL :: NtfCommand 'Subscription
@@ -176,7 +178,7 @@ deriving instance Show NtfCmd
 
 instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
   type Tag (NtfCommand e) = NtfCommandTag e
-  encodeProtocol = \case
+  encodeProtocol _v = \case
     TNEW newTkn -> e (TNEW_, ' ', newTkn)
     TVFY code -> e (TVFY_, ' ', code)
     TCHK -> e TCHK_
@@ -190,7 +192,7 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP (NCT (sNtfEntity @e) tag)
+  protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
 
   checkCredentials (sig, _, entityId, _) cmd = case cmd of
     -- TNEW and SNEW must have signature but NOT token/subscription IDs
@@ -211,9 +213,9 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
 
 instance ProtocolEncoding NtfCmd where
   type Tag NtfCmd = NtfCmdTag
-  encodeProtocol (NtfCmd _ c) = encodeProtocol c
+  encodeProtocol _v (NtfCmd _ c) = encodeProtocol _v c
 
-  protocolP = \case
+  protocolP _v = \case
     NCT SToken tag ->
       NtfCmd SToken <$> case tag of
         TNEW_ -> TNEW <$> _smpP
@@ -231,7 +233,8 @@ instance ProtocolEncoding NtfCmd where
   checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
 
 data NtfResponseTag
-  = NRId_
+  = NRTknId_
+  | NRSubId_
   | NROk_
   | NRErr_
   | NRTkn_
@@ -241,7 +244,8 @@ data NtfResponseTag
 
 instance Encoding NtfResponseTag where
   smpEncode = \case
-    NRId_ -> "ID"
+    NRTknId_ -> "IDTKN"
+    NRSubId_ -> "IDSUB"
     NROk_ -> "OK"
     NRErr_ -> "ERR"
     NRTkn_ -> "TKN"
@@ -251,7 +255,8 @@ instance Encoding NtfResponseTag where
 
 instance ProtocolMsgTag NtfResponseTag where
   decodeTag = \case
-    "ID" -> Just NRId_
+    "IDTKN" -> Just NRTknId_
+    "IDSUB" -> Just NRSubId_
     "OK" -> Just NROk_
     "ERR" -> Just NRErr_
     "TKN" -> Just NRTkn_
@@ -260,7 +265,8 @@ instance ProtocolMsgTag NtfResponseTag where
     _ -> Nothing
 
 data NtfResponse
-  = NRId NtfEntityId C.PublicKeyX25519
+  = NRTknId NtfEntityId C.PublicKeyX25519
+  | NRSubId NtfEntityId
   | NROk
   | NRErr ErrorType
   | NRTkn NtfTknStatus
@@ -270,8 +276,9 @@ data NtfResponse
 
 instance ProtocolEncoding NtfResponse where
   type Tag NtfResponse = NtfResponseTag
-  encodeProtocol = \case
-    NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
+  encodeProtocol _v = \case
+    NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
+    NRSubId entId -> e (NRSubId_, ' ', entId)
     NROk -> e NROk_
     NRErr err -> e (NRErr_, ' ', err)
     NRTkn stat -> e (NRTkn_, ' ', stat)
@@ -281,8 +288,9 @@ instance ProtocolEncoding NtfResponse where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP = \case
-    NRId_ -> NRId <$> _smpP <*> smpP
+  protocolP _v = \case
+    NRTknId_ -> NRTknId <$> _smpP <*> smpP
+    NRSubId_ -> NRSubId <$> _smpP
     NROk_ -> pure NROk
     NRErr_ -> NRErr <$> _smpP
     NRTkn_ -> NRTkn <$> _smpP
@@ -290,8 +298,10 @@ instance ProtocolEncoding NtfResponse where
     NRPong_ -> pure NRPong
 
   checkCredentials (_, _, entId, _) cmd = case cmd of
-    -- ID response must not have queue ID
-    NRId {} -> noEntity
+    -- IDTKN response must not have queue ID
+    NRTknId {} -> noEntity
+    -- IDSUB response must not have queue ID
+    NRSubId {} -> noEntity
     -- ERR response does not always have entity ID
     NRErr _ -> Right cmd
     -- PONG response must not have queue ID
@@ -307,16 +317,15 @@ instance ProtocolEncoding NtfResponse where
 
 data SMPQueueNtf = SMPQueueNtf
   { smpServer :: ProtocolServer,
-    notifierId :: NotifierId,
-    notifierKey :: NtfPrivateSignKey
+    notifierId :: NotifierId
   }
-  deriving (Show)
+  deriving (Eq, Ord, Show)
 
 instance Encoding SMPQueueNtf where
-  smpEncode SMPQueueNtf {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
+  smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
   smpP = do
-    (smpServer, notifierId, notifierKey) <- smpP
-    pure $ SMPQueueNtf smpServer notifierId notifierKey
+    (smpServer, notifierId) <- smpP
+    pure $ SMPQueueNtf smpServer notifierId
 
 data PushProvider = PPApns
   deriving (Eq, Ord, Show)

src/Simplex/Messaging/Notifications/Server.hs

@@ -16,6 +16,7 @@ import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
+import Data.Functor (($>))
 import qualified Data.Text as T
 import Data.Time.Clock.System (getSystemTime)
 import Network.Socket (ServiceName)
@@ -26,7 +27,7 @@ import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (ErrorType (..), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import qualified Simplex.Messaging.TMap as TM
@@ -34,7 +35,7 @@ import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Trans
 import Simplex.Messaging.Transport.Server (runTransportServer)
 import Simplex.Messaging.Util
 import UnliftIO (async, uninterruptibleCancel)
-import UnliftIO.Concurrent (threadDelay)
+import UnliftIO.Concurrent (forkFinally, threadDelay)
 import UnliftIO.Exception
 import UnliftIO.STM
 
@@ -60,35 +61,58 @@ ntfServer NtfServerConfig {transports} started = do
     runClient :: Transport c => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
-      liftIO (runExceptT $ ntfServerHandshake h kh) >>= \case
+      liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
         Right th -> runNtfClientTransport th
         Left _ -> pure ()
 
-ntfSubscriber :: forall m. MonadUnliftIO m => NtfSubscriber -> m ()
-ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
+ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
+ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
   raceAny_ [subscribe, receiveSMP, receiveAgent]
   where
     subscribe :: m ()
-    subscribe = forever $ do
-      atomically (readTBQueue subQ) >>= \case
-        NtfSub NtfSubData {smpQueue} -> do
-          let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue
-          liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
-            Right _ -> pure () -- update subscription status
-            Left _e -> pure ()
+    subscribe =
+      forever $
+        atomically (readTBQueue newSubQ) >>= \case
+          sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
+            SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
+            atomically $ writeTBQueue subscriberSubQ sub
+
+    getSMPSubscriber :: SMPServer -> m SMPSubscriber
+    getSMPSubscriber smpServer =
+      atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
+      where
+        createSMPSubscriber = do
+          qSize <- asks $ subQSize . config
+          newSubscriber <- atomically $ newSMPSubscriber qSize
+          atomically $ TM.insert smpServer newSubscriber smpSubscribers
+          _ <- runSMPSubscriber newSubscriber `forkFinally` \_ -> atomically (TM.delete smpServer smpSubscribers >> failSubscriptions newSubscriber)
+          pure newSubscriber
+        -- TODO mark subscriptions as failed
+        failSubscriptions _ = pure ()
+
+    runSMPSubscriber :: SMPSubscriber -> m ()
+    runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
+      forever $
+        atomically (peekTBQueue subscriberSubQ) >>= \case
+          NtfSub NtfSubData {smpQueue, notifierKey} -> do
+            let SMPQueueNtf {smpServer, notifierId} = smpQueue
+            liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
+              Right _ -> do
+                -- update subscription status
+                _ <- atomically $ readTBQueue subscriberSubQ
+                pure ()
+              Left _e -> pure ()
 
     receiveSMP :: m ()
     receiveSMP = forever $ do
-      (_srv, _sessId, _ntfId, msg) <- atomically $ readTBQueue msgQ
+      (srv, _sessId, ntfId, msg) <- atomically $ readTBQueue msgQ
       case msg of
         SMP.NMSG -> do
-          -- check when the last NMSG was received from this queue
-          -- update timestamp
-          -- check what was the last hidden notification was sent (and whether to this queue)
-          -- decide whether it should be sent as hidden or visible
-          -- construct and possibly encrypt notification
-          -- send it
-          pure ()
+          NtfPushServer {pushQ} <- asks pushServer
+          st <- asks store
+          atomically $
+            findNtfSubscriptionToken st (SMPQueueNtf srv ntfId)
+              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage srv ntfId))
         _ -> pure ()
       pure ()
 
@@ -119,6 +143,8 @@ ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
       atomically $ modifyTVar tknStatus $ \status' -> if status' == NTActive then NTActive else NTConfirmed
     (NTActive, PNCheckMessages) -> do
       deliverNotification pp tkn ntf
+    (NTActive, PNMessage _ _) -> do
+      deliverNotification pp tkn ntf
     _ -> do
       logError "bad notification token status"
   where
@@ -159,11 +185,14 @@ receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
     write q t = atomically $ writeTBQueue q t
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
-send h NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
+send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
+  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
+-- instance Show a => Show (TVar a) where
+--   show x = unsafePerformIO $ show <$> readTVarIO x
+
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
 verifyNtfTransmission ::
@@ -183,17 +212,45 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
           else VRFailed
     NtfCmd SToken c -> do
       t_ <- atomically $ getNtfToken st entId
-      pure $ case t_ of
-        Just t@NtfTknData {tknVerifyKey}
-          | verifyCmdSignature sig_ signed tknVerifyKey -> verifiedTknCmd t c
-          | otherwise -> VRFailed
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    _ -> pure VRFailed
+      verifyToken t_ (`verifiedTknCmd` c)
+    NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> do
+      s_ <- atomically $ findNtfSubscription st smpQueue
+      case s_ of
+        Nothing -> do
+          -- TODO move active token check here to differentiate error
+          t_ <- atomically $ getActiveNtfToken st tknId
+          verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
+        Just s@NtfSubData {tokenId = subTknId} ->
+          if subTknId == tknId
+            then do
+              -- TODO move active token check here to differentiate error
+              t_ <- atomically $ getActiveNtfToken st subTknId
+              verifyToken' t_ $ verifiedSubCmd s c
+            else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    NtfCmd SSubscription c -> do
+      s_ <- atomically $ getNtfSubscription st entId
+      case s_ of
+        Just s@NtfSubData {tokenId = subTknId} -> do
+          -- TODO move active token check here to differentiate error
+          t_ <- atomically $ getActiveNtfToken st subTknId
+          verifyToken' t_ $ verifiedSubCmd s c
+        _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
   where
     verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
+    verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
+    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> m VerificationResult
+    verifyToken t_ positiveVerificationResult =
+      pure $ case t_ of
+        Just t@NtfTknData {tknVerifyKey} ->
+          if verifyCmdSignature sig_ signed tknVerifyKey
+            then positiveVerificationResult t
+            else VRFailed
+        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    verifyToken' :: Maybe NtfTknData -> VerificationResult -> m VerificationResult
+    verifyToken' t_ = verifyToken t_ . const
 
 client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
-client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ, intervalNotifiers} =
+client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ, intervalNotifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
@@ -212,7 +269,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {push
           tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
           addNtfToken st tknId tkn
           writeTBQueue pushQ (tkn, PNVerification regCode)
-        pure (corrId, "", NRId tknId srvDhPubKey)
+        pure (corrId, "", NRTknId tknId srvDhPubKey)
       NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
         (corrId,tknId,) <$> case cmd of
@@ -223,7 +280,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {push
             if tknDhSecret == dhSecret
               then do
                 atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
-                pure $ NRId ntfTknId srvDhPubKey
+                pure $ NRTknId ntfTknId srvDhPubKey
               else pure $ NRErr AUTH
           TVFY code -- this allows repeated verification for cases when client connection dropped before server response
             | (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
@@ -267,11 +324,28 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {push
                   intervalNotifier delay = forever $ do
                     threadDelay delay
                     atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
-      NtfReqNew corrId (ANE SSubscription _newSub) -> pure (corrId, "", NROk)
-      NtfReqCmd SSubscription _sub (corrId, subId, cmd) ->
+      NtfReqNew corrId (ANE SSubscription newSub) -> do
+        logDebug "SNEW - new subscription"
+        st <- asks store
+        subId <- getId
+        atomically $ do
+          sub <- mkNtfSubData newSub
+          (corrId,"",)
+            <$> ( addNtfSubscription st subId sub >>= \case
+                    Just _ -> writeTBQueue newSubQ (NtfSub sub) $> NRSubId subId
+                    _ -> pure $ NRErr AUTH
+                )
+      NtfReqCmd SSubscription (NtfSub NtfSubData {notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
+        status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
-          SNEW _newSub -> pure NROk
-          SCHK -> pure NROk
+          SNEW (NewNtfSub _ _ notifierKey) -> do
+            logDebug "SNEW - existing subscription"
+            -- TODO retry if subscription failed, if pending or AUTH do nothing
+            pure $
+              if notifierKey == registeredNKey
+                then NRSubId subId
+                else NRErr AUTH
+          SCHK -> pure $ NRSub status
           SDEL -> pure NROk
           PING -> pure NRPong
     getId :: m NtfEntityId

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

@@ -23,7 +23,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (CorrId, Transmission)
+import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -78,15 +78,26 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
   pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
 
 data NtfSubscriber = NtfSubscriber
-  { subQ :: TBQueue (NtfEntityRec 'Subscription),
+  { smpSubscribers :: TMap SMPServer SMPSubscriber,
+    newSubQ :: TBQueue (NtfEntityRec 'Subscription),
     smpAgent :: SMPClientAgent
   }
 
 newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
 newNtfSubscriber qSize smpAgentCfg = do
+  smpSubscribers <- TM.empty
+  newSubQ <- newTBQueue qSize
   smpAgent <- newSMPClientAgent smpAgentCfg
-  subQ <- newTBQueue qSize
-  pure NtfSubscriber {smpAgent, subQ}
+  pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
+
+newtype SMPSubscriber = SMPSubscriber
+  { newSubQ :: TBQueue (NtfEntityRec 'Subscription)
+  }
+
+newSMPSubscriber :: Natural -> STM SMPSubscriber
+newSMPSubscriber qSize = do
+  newSubQ <- newTBQueue qSize
+  pure SMPSubscriber {newSubQ}
 
 data NtfPushServer = NtfPushServer
   { pushQ :: TBQueue (NtfTknData, PushNotification),

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

@@ -15,6 +15,12 @@ export JWT_HEADER_CLAIMS="${JWT_HEADER}.${JWT_CLAIMS}"
 export JWT_SIGNED_HEADER_CLAIMS=$(printf "${JWT_HEADER_CLAIMS}" | openssl dgst -binary -sha256 -sign "${APNS_KEY_FILE}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
 export AUTHENTICATION_TOKEN="${JWT_HEADER}.${JWT_CLAIMS}.${JWT_SIGNED_HEADER_CLAIMS}"
 
-curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"},"data":{"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
+# simple alert
+# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"},"data":{"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
 
+# background notification
 # curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: background" --header "apns-priority: 5" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"content-available":1}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
+
+# mutable-content notification
+# NTF_CAT_CHECK_MESSAGE category will not show alert if the app is in foreground
+curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"category": "NTF_CAT_CHECK_MESSAGE__SECRET", "mutable-content": 1, "alert":"received encrypted message"}, "data": {"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}

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

@@ -6,7 +6,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Notifications.Server.Store where
 
@@ -14,22 +13,31 @@ import Control.Concurrent.STM
 import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.Map.Strict as M
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Protocol (NtfPrivateSignKey)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
 
 data NtfStore = NtfStore
   { tokens :: TMap NtfTokenId NtfTknData,
-    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId)
+    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
+    subscriptions :: TMap NtfSubscriptionId NtfSubData,
+    tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
+    subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
   }
 
 newNtfStore :: STM NtfStore
 newNtfStore = do
   tokens <- TM.empty
   tokenRegistrations <- TM.empty
-  pure NtfStore {tokens, tokenRegistrations}
+  subscriptions <- TM.empty
+  tokenSubscriptions <- TM.empty
+  subscriptionLookup <- TM.empty
+  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
 
 data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
@@ -58,6 +66,7 @@ mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tkn
 
 data NtfSubData = NtfSubData
   { smpQueue :: SMPQueueNtf,
+    notifierKey :: NtfPrivateSignKey,
     tokenId :: NtfTokenId,
     subStatus :: TVar NtfSubStatus
   }
@@ -118,6 +127,46 @@ deleteNtfToken st tknId = do
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes
 
+getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
+getNtfSubscription st subId =
+  TM.lookup subId (subscriptions st)
+
+findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
+findNtfSubscription st smpQueue = do
+  TM.lookup smpQueue (subscriptionLookup st)
+    $>>= \subId -> TM.lookup subId (subscriptions st)
+
+findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
+findNtfSubscriptionToken st smpQueue = do
+  findNtfSubscription st smpQueue
+    $>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
+
+getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
+getActiveNtfToken st tknId =
+  getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
+    tStatus <- readTVar tknStatus
+    pure $ if tStatus == NTActive then Just tkn else Nothing
+
+mkNtfSubData :: NewNtfEntity 'Subscription -> STM NtfSubData
+mkNtfSubData (NewNtfSub tokenId smpQueue notifierKey) = do
+  subStatus <- newTVar NSNew
+  pure NtfSubData {smpQueue, tokenId, subStatus, notifierKey}
+
+addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
+addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
+  TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
+  where
+    newTokenSub = do
+      ts <- newTVar S.empty
+      TM.insert tokenId ts $ tokenSubscriptions st
+      pure ts
+    insertSub ts = do
+      modifyTVar' ts $ S.insert subId
+      TM.insert subId sub $ subscriptions st
+      TM.insert smpQueue subId (subscriptionLookup st)
+      -- return Nothing if subscription existed before
+      pure $ Just ()
+
 -- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
 -- getNtfRec st ent entId = case ent of
 --   SToken -> NtfTkn <$$> TM.lookup entId (tokens st)

src/Simplex/Messaging/Notifications/Transport.hs

@@ -3,17 +3,21 @@ module Simplex.Messaging.Notifications.Transport where
 import Control.Monad.Except
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Version
 
 ntfBlockSize :: Int
 ntfBlockSize = 512
 
+supportedNTFServerVRange :: VersionRange
+supportedNTFServerVRange = mkVersionRange 1 1
+
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c _ = pure $ ntfTHandle c
+ntfServerHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfServerHandshake c _ _ = pure $ ntfTHandle c
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-ntfClientHandshake c _ = pure $ ntfTHandle c
+ntfClientHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfClientHandshake c _ _ = pure $ ntfTHandle c
 
 ntfTHandle :: Transport c => c -> THandle c
 ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}

src/Simplex/Messaging/Protocol.hs

@@ -78,6 +78,8 @@ module Simplex.Messaging.Protocol
     NtfPublicVerifyKey,
     MsgId,
     MsgBody,
+    MsgFlags (..),
+    noMsgFlags,
 
     -- * Parse and serialize
     ProtocolMsgTag (..),
@@ -214,11 +216,16 @@ data Command (p :: Party) where
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
   NKEY :: NtfPublicVerifyKey -> Command Recipient
-  ACK :: Command Recipient
+  GET :: Command Recipient
+  -- ACK v1 has to be supported for encoding/decoding
+  -- ACK :: Command Recipient
+  ACK :: MsgId -> Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
   -- SMP sender commands
-  SEND :: MsgBody -> Command Sender
+  -- SEND v1 has to be supported for encoding/decoding
+  -- SEND :: MsgBody -> Command Sender
+  SEND :: MsgFlags -> MsgBody -> Command Sender
   PING :: Command Sender
   -- SMP notification subscriber commands
   NSUB :: Command Notifier
@@ -230,7 +237,9 @@ deriving instance Eq (Command p)
 data BrokerMsg where
   -- SMP broker messages (responses, client messages, notifications)
   IDS :: QueueIdsKeys -> BrokerMsg
-  MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  -- MSG v1 has to be supported for encoding/decoding
+  -- MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  MSG :: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
   NID :: NotifierId -> BrokerMsg
   NMSG :: BrokerMsg
   END :: BrokerMsg
@@ -239,6 +248,24 @@ data BrokerMsg where
   PONG :: BrokerMsg
   deriving (Eq, Show)
 
+newtype MsgFlags = MsgFlags {notification :: Bool}
+  deriving (Eq, Show)
+
+instance Encoding MsgFlags where
+  smpEncode MsgFlags {notification} = smpEncode notification
+  smpP = do
+    notification <- smpP <* A.takeTill (== ' ')
+    pure MsgFlags {notification}
+
+instance StrEncoding MsgFlags where
+  strEncode = smpEncode
+  {-# INLINE strEncode #-}
+  strP = smpP
+  {-# INLINE strP #-}
+
+noMsgFlags :: MsgFlags
+noMsgFlags = MsgFlags {notification = False}
+
 -- * SMP command tags
 
 data CommandTag (p :: Party) where
@@ -246,6 +273,7 @@ data CommandTag (p :: Party) where
   SUB_ :: CommandTag Recipient
   KEY_ :: CommandTag Recipient
   NKEY_ :: CommandTag Recipient
+  GET_ :: CommandTag Recipient
   ACK_ :: CommandTag Recipient
   OFF_ :: CommandTag Recipient
   DEL_ :: CommandTag Recipient
@@ -284,6 +312,7 @@ instance PartyI p => Encoding (CommandTag p) where
     SUB_ -> "SUB"
     KEY_ -> "KEY"
     NKEY_ -> "NKEY"
+    GET_ -> "GET"
     ACK_ -> "ACK"
     OFF_ -> "OFF"
     DEL_ -> "DEL"
@@ -298,6 +327,7 @@ instance ProtocolMsgTag CmdTag where
     "SUB" -> Just $ CT SRecipient SUB_
     "KEY" -> Just $ CT SRecipient KEY_
     "NKEY" -> Just $ CT SRecipient NKEY_
+    "GET" -> Just $ CT SRecipient GET_
     "ACK" -> Just $ CT SRecipient ACK_
     "OFF" -> Just $ CT SRecipient OFF_
     "DEL" -> Just $ CT SRecipient DEL_
@@ -476,10 +506,10 @@ type SndPrivateSignKey = C.APrivateSignKey
 -- | Sender's public key used by SMP server to verify authorization of SMP commands.
 type SndPublicVerifyKey = C.APublicVerifyKey
 
--- | Private key used by push notifications server to authorize (sign) LSTN command.
+-- | Private key used by push notifications server to authorize (sign) NSUB command.
 type NtfPrivateSignKey = C.APrivateSignKey
 
--- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server.
+-- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
 type NtfPublicVerifyKey = C.APublicVerifyKey
 
 -- | SMP message server ID.
@@ -526,6 +556,8 @@ data CommandError
     UNKNOWN
   | -- | error parsing command
     SYNTAX
+  | -- | command is not allowed (SUB/GET cannot be used with the same queue in the same TCP connection)
+    PROHIBITED
   | -- | transmission has no required credentials (signature or queue ID)
     NO_AUTH
   | -- | transmission has credentials that are not allowed for this command
@@ -558,7 +590,7 @@ transmissionP = do
 
 class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
   type ProtocolCommand msg = cmd | cmd -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
   protocolPing :: ProtocolCommand msg
   protocolError :: msg -> Maybe ErrorType
 
@@ -572,28 +604,33 @@ instance Protocol BrokerMsg where
 
 class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
   type Tag msg
-  encodeProtocol :: msg -> ByteString
-  protocolP :: Tag msg -> Parser msg
+  encodeProtocol :: Version -> msg -> ByteString
+  protocolP :: Version -> Tag msg -> Parser msg
   checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
 
 instance PartyI p => ProtocolEncoding (Command p) where
   type Tag (Command p) = CommandTag p
-  encodeProtocol = \case
+  encodeProtocol v = \case
     NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
     NKEY k -> e (NKEY_, ' ', k)
-    ACK -> e ACK_
+    GET -> e GET_
+    ACK msgId
+      | v == 1 -> e ACK_
+      | otherwise -> e (ACK_, ' ', msgId)
     OFF -> e OFF_
     DEL -> e DEL_
-    SEND msg -> e (SEND_, ' ', Tail msg)
+    SEND flags msg
+      | v == 1 -> e (SEND_, ' ', Tail msg)
+      | otherwise -> e (SEND_, ' ', flags, ' ', Tail msg)
     PING -> e PING_
     NSUB -> e NSUB_
     where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag)
+  protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
 
   checkCredentials (sig, _, queueId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
@@ -602,7 +639,7 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | not (B.null queueId) -> Left $ CMD HAS_AUTH
       | otherwise -> Right cmd
     -- SEND must have queue ID, signature is not always required
-    SEND _
+    SEND {}
       | B.null queueId -> Left $ CMD NO_ENTITY
       | otherwise -> Right cmd
     -- PING must not have queue ID or signature
@@ -616,21 +653,26 @@ instance PartyI p => ProtocolEncoding (Command p) where
 
 instance ProtocolEncoding Cmd where
   type Tag Cmd = CmdTag
-  encodeProtocol (Cmd _ c) = encodeProtocol c
+  encodeProtocol v (Cmd _ c) = encodeProtocol v c
 
-  protocolP = \case
+  protocolP v = \case
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
         NEW_ -> NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
         NKEY_ -> NKEY <$> _smpP
-        ACK_ -> pure ACK
+        GET_ -> pure GET
+        ACK_
+          | v == 1 -> pure $ ACK ""
+          | otherwise -> ACK <$> _smpP
         OFF_ -> pure OFF
         DEL_ -> pure DEL
     CT SSender tag ->
       Cmd SSender <$> case tag of
-        SEND_ -> SEND . unTail <$> _smpP
+        SEND_
+          | v == 1 -> SEND <$> pure noMsgFlags <*> (unTail <$> _smpP)
+          | otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
         PING_ -> pure PING
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
 
@@ -638,9 +680,11 @@ instance ProtocolEncoding Cmd where
 
 instance ProtocolEncoding BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
-  encodeProtocol = \case
+  encodeProtocol v = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
-    MSG msgId ts msgBody -> e (MSG_, ' ', msgId, ts, Tail msgBody)
+    MSG msgId ts flags msgBody
+      | v == 1 -> e (MSG_, ' ', msgId, ts, Tail msgBody)
+      | otherwise -> e (MSG_, ' ', msgId, ts, flags, ' ', Tail msgBody)
     NID nId -> e (NID_, ' ', nId)
     NMSG -> e NMSG_
     END -> e END_
@@ -651,8 +695,10 @@ instance ProtocolEncoding BrokerMsg where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP = \case
-    MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP)
+  protocolP v = \case
+    MSG_
+      | v == 1 -> MSG <$> _smpP <*> smpP <*> pure noMsgFlags <*> (unTail <$> smpP)
+      | otherwise -> MSG <$> _smpP <*> smpP <*> smpP <*> (unTail <$> _smpP)
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
     NID_ -> NID <$> _smpP
     NMSG_ -> pure NMSG
@@ -679,11 +725,11 @@ _smpP :: Encoding a => Parser a
 _smpP = A.space *> smpP
 
 -- | Parse SMP protocol commands and broker messages
-parseProtocol :: ProtocolEncoding msg => ByteString -> Either ErrorType msg
-parseProtocol s =
+parseProtocol :: ProtocolEncoding msg => Version -> ByteString -> Either ErrorType msg
+parseProtocol v s =
   let (tag, params) = B.break (== ' ') s
    in case decodeTag tag of
-        Just cmd -> parse (protocolP cmd) (CMD SYNTAX) params
+        Just cmd -> parse (protocolP v cmd) (CMD SYNTAX) params
         Nothing -> Left $ CMD UNKNOWN
 
 checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
@@ -725,6 +771,7 @@ instance Encoding CommandError where
   smpEncode e = case e of
     UNKNOWN -> "UNKNOWN"
     SYNTAX -> "SYNTAX"
+    PROHIBITED -> "PROHIBITED"
     NO_AUTH -> "NO_AUTH"
     HAS_AUTH -> "HAS_AUTH"
     NO_ENTITY -> "NO_ENTITY"
@@ -732,6 +779,7 @@ instance Encoding CommandError where
     A.takeTill (== ' ') >>= \case
       "UNKNOWN" -> pure UNKNOWN
       "SYNTAX" -> pure SYNTAX
+      "PROHIBITED" -> pure PROHIBITED
       "NO_AUTH" -> pure NO_AUTH
       "HAS_AUTH" -> pure HAS_AUTH
       "NO_ENTITY" -> pure NO_ENTITY
@@ -742,9 +790,9 @@ instance Encoding CommandError where
 tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
 tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
 
-encodeTransmission :: ProtocolEncoding c => ByteString -> Transmission c -> ByteString
-encodeTransmission sessionId (CorrId corrId, queueId, command) =
-  smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
+encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
+encodeTransmission v sessionId (CorrId corrId, queueId, command) =
+  smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
 tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
@@ -752,7 +800,7 @@ tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
 
 -- | Receive client and server transmissions (determined by `cmd` type).
 tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
-tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
+tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= decodeParseValidate
   where
     decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case
@@ -768,5 +816,5 @@ tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
 
     tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
     tParseValidate signed t@(sig, corrId, entityId, command) = do
-      let cmd = parseProtocol command >>= checkCredentials t
+      let cmd = parseProtocol v command >>= checkCredentials t
       pure (sig, signed, (CorrId corrId, entityId, cmd))

src/Simplex/Messaging/Server.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -45,13 +46,17 @@ import Data.Functor (($>))
 import Data.List (intercalate)
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing)
+import Data.Set (Set)
 import qualified Data.Set as S
 import qualified Data.Text as T
+import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Type.Equality
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
@@ -65,7 +70,9 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
+import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
+import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
@@ -89,12 +96,13 @@ smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m (
 smpServer started = do
   s <- asks server
   cfg@ServerConfig {transports} <- asks config
+  restoreServerMessages
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
       map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
     )
-    `finally` withLog closeStoreLog
+    `finally` (withLog closeStoreLog >> saveServerMessages)
   where
     runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
@@ -155,9 +163,9 @@ smpServer started = do
     logServerStats :: Int -> Int -> m ()
     logServerStats startAt logInterval = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      logInfo $ "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,msgQueues"
+      logInfo $ "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
       threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgQueues} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
       let interval = 1000000 * logInterval
       forever $ do
         ts <- liftIO getCurrentTime
@@ -167,14 +175,23 @@ smpServer started = do
         qDeleted' <- atomically $ swapTVar qDeleted 0
         msgSent' <- atomically $ swapTVar msgSent 0
         msgRecv' <- atomically $ swapTVar msgRecv 0
-        msgQueues' <- atomically $ S.size <$> swapTVar msgQueues S.empty
-        logInfo . T.pack $ intercalate "," [show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show msgQueues']
+        let day = utctDay ts
+            (_, wDay) = mondayStartWeek day
+            MonthDay _ mDay = day
+        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
+          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
+        logInfo . T.pack $ intercalate "," [show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
         threadDelay interval
+      where
+        periodCount :: Int -> TVar (Set RecipientId) -> STM String
+        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
+        periodCount _ _ = pure ""
 
     runClient :: Transport c => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
-      liftIO (runExceptT $ smpServerHandshake h kh) >>= \case
+      smpVRange <- asks $ smpServerVRange . config
+      liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
         Right th -> runClientTransport th
         Left _ -> pure ()
 
@@ -196,6 +213,7 @@ clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
   mapM_ cancelSub subs
+  atomically $ writeTVar subscriptions M.empty
   cs <- asks $ subscribers . server
   atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
   where
@@ -207,10 +225,11 @@ clientDisconnected c@Client {subscriptions, connected} = do
 sameClientSession :: Client -> Client -> Bool
 sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
-cancelSub :: MonadUnliftIO m => Sub -> m ()
-cancelSub = \case
-  Sub {subThread = SubThread t} -> killThread t
-  _ -> return ()
+cancelSub :: MonadUnliftIO m => TVar Sub -> m ()
+cancelSub sub =
+  readTVarIO sub >>= \case
+    Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
+    _ -> return ()
 
 receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
 receive th Client {rcvQ, sndQ, activeAt} = forever $ do
@@ -227,10 +246,10 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
     write q t = atomically $ writeTBQueue q t
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
-send h Client {sndQ, sessionId, activeAt} = forever $ do
+send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
   -- TODO the line below can return Left, but we ignore it and do not disconnect the client
-  void . liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
+  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
@@ -248,7 +267,7 @@ verifyTransmission sig_ signed queueId cmd = do
   case cmd of
     Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
-    Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
+    Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
     Cmd SSender PING -> pure True
     Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
   where
@@ -298,7 +317,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
       case cmd of
         Cmd SSender command ->
           case command of
-            SEND msgBody -> sendMessage st msgBody
+            SEND flags msgBody -> sendMessage st flags msgBody
             PING -> pure (corrId, "", PONG)
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
@@ -309,7 +328,8 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
             SUB -> subscribeQueue queueId
-            ACK -> acknowledgeMsg
+            GET -> getMessage
+            ACK msgId -> acknowledgeMsg msgId
             KEY sKey -> secureQueue_ st sKey
             NKEY nKey -> addQueueNotifier_ st nKey
             OFF -> suspendQueue_ st
@@ -386,17 +406,55 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
 
         subscribeQueue :: RecipientId -> m (Transmission BrokerMsg)
         subscribeQueue rId =
-          atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId
-
-        getSubscription :: RecipientId -> STM Sub
-        getSubscription rId = do
-          TM.lookup rId subscriptions >>= \case
-            Just s -> tryTakeTMVar (delivered s) $> s
-            Nothing -> do
+          atomically (TM.lookup rId subscriptions) >>= \case
+            Nothing ->
+              atomically newSub >>= deliver
+            Just sub ->
+              readTVarIO sub >>= \case
+                Sub {subThread = ProhibitSub} ->
+                  -- cannot use SUB in the same connection where GET was used
+                  pure (corrId, rId, ERR $ CMD PROHIBITED)
+                s ->
+                  atomically (tryTakeTMVar $ delivered s) >> deliver sub
+          where
+            newSub :: STM (TVar Sub)
+            newSub = do
               writeTBQueue subscribedQ (rId, clnt)
-              s <- newSubscription
-              TM.insert rId s subscriptions
-              return s
+              sub <- newTVar =<< newSubscription NoSub
+              TM.insert rId sub subscriptions
+              pure sub
+            deliver :: TVar Sub -> m (Transmission BrokerMsg)
+            deliver sub = do
+              q <- getStoreMsgQueue rId
+              msg_ <- atomically $ tryPeekMsg q
+              deliverMessage rId sub q msg_
+
+        getMessage :: m (Transmission BrokerMsg)
+        getMessage =
+          atomically (TM.lookup queueId subscriptions) >>= \case
+            Nothing ->
+              atomically newSub >>= getMessage_
+            Just sub ->
+              readTVarIO sub >>= \case
+                s@Sub {subThread = ProhibitSub} ->
+                  atomically (tryTakeTMVar $ delivered s)
+                    >> getMessage_ s
+                -- cannot use GET in the same connection where there is an active subscription
+                _ -> pure (corrId, queueId, ERR $ CMD PROHIBITED)
+          where
+            newSub :: STM Sub
+            newSub = do
+              s <- newSubscription ProhibitSub
+              sub <- newTVar s
+              TM.insert queueId sub subscriptions
+              pure s
+            getMessage_ :: Sub -> m (Transmission BrokerMsg)
+            getMessage_ s = do
+              q <- getStoreMsgQueue queueId
+              atomically $
+                tryPeekMsg q >>= \case
+                  Just msg -> setDelivered s msg $> (corrId, queueId, msgCmd msg)
+                  _ -> pure (corrId, queueId, OK)
 
         subscribeNotifications :: m (Transmission BrokerMsg)
         subscribeNotifications = atomically $ do
@@ -405,22 +463,48 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             TM.insert queueId () ntfSubscriptions
           pure ok
 
-        acknowledgeMsg :: m (Transmission BrokerMsg)
-        acknowledgeMsg =
-          atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
-            >>= \case
-              Just (Just s) -> do
-                stats <- asks serverStats
-                atomically $ modifyTVar (msgRecv stats) (+ 1)
-                atomically $ modifyTVar (msgQueues stats) (S.insert queueId)
-                deliverMessage tryDelPeekMsg queueId s
-              _ -> return $ err NO_MSG
+        acknowledgeMsg :: MsgId -> m (Transmission BrokerMsg)
+        acknowledgeMsg msgId = do
+          atomically (TM.lookup queueId subscriptions) >>= \case
+            Nothing -> pure $ err NO_MSG
+            Just sub ->
+              atomically (getDelivered sub) >>= \case
+                Just s -> do
+                  q <- getStoreMsgQueue queueId
+                  case s of
+                    Sub {subThread = ProhibitSub} -> do
+                      msgDeleted <- atomically $ tryDelMsg q msgId
+                      when msgDeleted updateStats
+                      pure ok
+                    _ -> do
+                      (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
+                      when msgDeleted updateStats
+                      deliverMessage queueId sub q msg_
+                _ -> pure $ err NO_MSG
+          where
+            getDelivered :: TVar Sub -> STM (Maybe Sub)
+            getDelivered sub = do
+              s@Sub {delivered} <- readTVar sub
+              tryTakeTMVar delivered $>>= \msgId' ->
+                if B.null msgId || msgId == msgId'
+                  then pure $ Just s
+                  else putTMVar delivered msgId' $> Nothing
+            updateStats :: m ()
+            updateStats = do
+              stats <- asks serverStats
+              atomically $ modifyTVar (msgRecv stats) (+ 1)
+              atomically $ updateActiveQueues stats queueId
 
-        withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
-        withSub rId f = mapM f =<< TM.lookup rId subscriptions
+        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
+        updateActiveQueues stats qId = do
+          updatePeriod dayMsgQueues
+          updatePeriod weekMsgQueues
+          updatePeriod monthMsgQueues
+          where
+            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
 
-        sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage st msgBody
+        sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage st flags msgBody
           | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
           | otherwise = do
             qr <- atomically $ getQueue st SSender queueId
@@ -440,13 +524,13 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                       q <- getMsgQueue ms (recipientId qr) msgQueueQuota
                       mapM_ (deleteExpiredMsgs q) old
                       ifM (isFull q) (pure $ err QUOTA) $ do
-                        trySendNotification
+                        when (notification flags) trySendNotification
                         writeMsg q msg
                         pure ok
                     when (sent == OK) $ do
                       stats <- asks serverStats
                       atomically $ modifyTVar (msgSent stats) (+ 1)
-                      atomically $ modifyTVar (msgQueues stats) (S.insert $ recipientId qr)
+                      atomically $ updateActiveQueues stats $ recipientId qr
                     pure resp
               where
                 mkMessage :: m (Either C.CryptoError Message)
@@ -454,7 +538,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                   msgId <- randomId =<< asks (msgIdBytes . config)
                   ts <- liftIO getSystemTime
                   let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
-                  pure $ Message msgId ts <$> c
+                  pure $ Message msgId ts flags <$> c
 
                 trySendNotification :: STM ()
                 trySendNotification =
@@ -466,40 +550,42 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                   unlessM (isFullTBQueue sndQ) $
                     writeTBQueue q (CorrId "", nId, NMSG)
 
-        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg)
-        deliverMessage tryPeek rId = \case
-          Sub {subThread = NoSub} -> do
-            ms <- asks msgStore
-            quota <- asks $ msgQueueQuota . config
-            q <- atomically $ getMsgQueue ms rId quota
-            atomically (tryPeek q) >>= \case
-              Nothing -> forkSub q $> ok
-              Just msg -> atomically setDelivered $> (corrId, rId, msgCmd msg)
-          _ -> pure ok
+        deliverMessage :: RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
+        deliverMessage rId sub q msg_ =
+          readTVarIO sub >>= \case
+            s@Sub {subThread = NoSub} ->
+              case msg_ of
+                Just msg -> atomically (setDelivered s msg) $> (corrId, rId, msgCmd msg)
+                _ -> forkSub $> ok
+            _ -> pure ok
           where
-            forkSub :: MsgQueue -> m ()
-            forkSub q = do
-              atomically . setSub $ \s -> s {subThread = SubPending}
-              t <- forkIO $ subscriber q
-              atomically . setSub $ \case
+            forkSub :: m ()
+            forkSub = do
+              atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
+              t <- mkWeakThreadId =<< forkIO subscriber
+              atomically . modifyTVar sub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
 
-            subscriber :: MsgQueue -> m ()
-            subscriber q = atomically $ do
+            subscriber :: m ()
+            subscriber = atomically $ do
               msg <- peekMsg q
               writeTBQueue sndQ (CorrId "", rId, msgCmd msg)
-              setSub (\s -> s {subThread = NoSub})
-              void setDelivered
+              s <- readTVar sub
+              void $ setDelivered s msg
+              writeTVar sub s {subThread = NoSub}
 
-            setSub :: (Sub -> Sub) -> STM ()
-            setSub f = TM.adjust f rId subscriptions
+        setDelivered :: Sub -> Message -> STM Bool
+        setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
 
-            setDelivered :: STM (Maybe Bool)
-            setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
+        getStoreMsgQueue :: RecipientId -> m MsgQueue
+        getStoreMsgQueue rId = do
+          ms <- asks msgStore
+          quota <- asks $ msgQueueQuota . config
+          atomically $ getMsgQueue ms rId quota
 
-            msgCmd :: Message -> BrokerMsg
-            msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
+        msgCmd :: Message -> BrokerMsg
+        msgCmd Message {msgId, ts, msgFlags, msgBody} = MSG msgId ts msgFlags msgBody
 
         delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
         delQueueAndMsgs st = do
@@ -530,3 +616,34 @@ randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
   atomically (C.pseudoRandomBytes n gVar)
+
+saveServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
+  where
+    saveMessages f = do
+      liftIO $ putStrLn $ "saving messages to file " <> f
+      ms <- asks msgStore
+      liftIO . withFile f WriteMode $ \h ->
+        readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
+      where
+        saveQueueMsgs ms h rId =
+          atomically (flushMsgQueue ms rId)
+            >>= mapM_ (B.hPutStrLn h . strEncode . MsgLogRecord rId)
+
+restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
+  where
+    restoreMessages f = whenM (doesFileExist f) $ do
+      liftIO $ putStrLn $ "restoring messages from file " <> f
+      ms <- asks msgStore
+      quota <- asks $ msgQueueQuota . config
+      liftIO $ mapM_ (restoreMsg ms quota) . B.lines =<< B.readFile f
+      renameFile f $ f <> ".bak"
+      where
+        restoreMsg ms quota s = case strDecode s of
+          Left e -> B.putStrLn $ "message parsing error (" <> B.pack e <> "): " <> B.take 100 s
+          Right (MsgLogRecord rId msg) -> do
+            full <- atomically $ do
+              q <- getMsgQueue ms rId quota
+              ifM (isFull q) (pure True) (writeMsg q msg $> False)
+            when full . B.putStrLn $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId msg)

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

@@ -31,7 +31,9 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Version
 import System.IO (IOMode (..))
+import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
@@ -42,6 +44,7 @@ data ServerConfig = ServerConfig
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
+    storeMsgsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
     -- | time after which the messages can be removed from the queues and check interval, seconds
@@ -57,7 +60,9 @@ data ServerConfig = ServerConfig
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    -- | SMP client-server protocol version range
+    smpServerVRange :: VersionRange
   }
 
 defaultMessageExpiration :: ExpirationConfig
@@ -94,7 +99,7 @@ data Server = Server
   }
 
 data Client = Client
-  { subscriptions :: TMap RecipientId Sub,
+  { subscriptions :: TMap RecipientId (TVar Sub),
     ntfSubscriptions :: TMap NotifierId (),
     rcvQ :: TBQueue (Transmission Cmd),
     sndQ :: TBQueue (Transmission BrokerMsg),
@@ -109,15 +114,17 @@ data ServerStats = ServerStats
     qDeleted :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
-    msgQueues :: TVar (Set RecipientId),
+    dayMsgQueues :: TVar (Set RecipientId),
+    weekMsgQueues :: TVar (Set RecipientId),
+    monthMsgQueues :: TVar (Set RecipientId),
     fromTime :: TVar UTCTime
   }
 
-data SubscriptionThread = NoSub | SubPending | SubThread ThreadId
+data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
 
 data Sub = Sub
   { subThread :: SubscriptionThread,
-    delivered :: TMVar ()
+    delivered :: TMVar MsgId
   }
 
 newServer :: Natural -> STM Server
@@ -145,14 +152,16 @@ newServerStats ts = do
   qDeleted <- newTVar 0
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
-  msgQueues <- newTVar S.empty
+  dayMsgQueues <- newTVar S.empty
+  weekMsgQueues <- newTVar S.empty
+  monthMsgQueues <- newTVar S.empty
   fromTime <- newTVar ts
-  pure ServerStats {qCreated, qSecured, qDeleted, msgSent, msgRecv, msgQueues, fromTime}
+  pure ServerStats {qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues, fromTime}
 
-newSubscription :: STM Sub
-newSubscription = do
+newSubscription :: SubscriptionThread -> STM Sub
+newSubscription subThread = do
   delivered <- newEmptyTMVar
-  return Sub {subThread = NoSub, delivered}
+  return Sub {subThread, delivered}
 
 newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
 newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do

src/Simplex/Messaging/Server/MsgStore.hs

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

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

@@ -2,16 +2,20 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
+import Control.Concurrent.STM.TBQueue (flushTBQueue)
 import Control.Monad (when)
+import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Numeric.Natural
-import Simplex.Messaging.Protocol (RecipientId)
+import Simplex.Messaging.Protocol (MsgId, RecipientId)
 import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -36,6 +40,9 @@ instance MonadMsgStore STMMsgStore MsgQueue STM where
   delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
   delMsgQueue st rId = TM.delete rId st
 
+  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
+
 instance MonadMsgQueue MsgQueue STM where
   isFull :: MsgQueue -> STM Bool
   isFull = isFullTBQueue . msgQueue
@@ -49,9 +56,22 @@ instance MonadMsgQueue MsgQueue STM where
   peekMsg :: MsgQueue -> STM Message
   peekMsg = peekTBQueue . msgQueue
 
+  tryDelMsg :: MsgQueue -> MsgId -> STM Bool
+  tryDelMsg (MsgQueue q) msgId' =
+    tryPeekTBQueue q >>= \case
+      Just Message {msgId}
+        | msgId == msgId' -> tryReadTBQueue q $> True
+        | otherwise -> pure False
+      _ -> pure False
+
   -- atomic delete (== read) last and peek next message if available
-  tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
-  tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q
+  tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
+  tryDelPeekMsg (MsgQueue q) msgId' =
+    tryPeekTBQueue q >>= \case
+      msg_@(Just Message {msgId})
+        | msgId == msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
+        | otherwise -> pure (False, msg_)
+      _ -> pure (False, Nothing)
 
   deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
   deleteExpiredMsgs (MsgQueue q) old = loop

src/Simplex/Messaging/Transport.hs

@@ -26,7 +26,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
 module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
-    supportedSMPVersions,
+    supportedSMPServerVRange,
     simplexMQVersion,
 
     -- * Transport connection class
@@ -92,11 +92,11 @@ import UnliftIO.STM
 smpBlockSize :: Int
 smpBlockSize = 16384
 
-supportedSMPVersions :: VersionRange
-supportedSMPVersions = mkVersionRange 1 1
+supportedSMPServerVRange :: VersionRange
+supportedSMPServerVRange = mkVersionRange 1 2
 
 simplexMQVersion :: String
-simplexMQVersion = "2.1.1"
+simplexMQVersion = "2.3.1"
 
 -- * Transport connection class
 
@@ -214,10 +214,11 @@ instance Transport TLS where
       readChunks :: ByteString -> IO ByteString
       readChunks b
         | B.length b >= n = pure b
-        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
-      handleEOF = \case
-        T.Error_EOF -> E.throwIO TEBadBlock
-        e -> E.throwIO e
+        | otherwise =
+          T.recvData tlsContext >>= \case
+            -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
+            "" -> ioe_EOF
+            s -> readChunks $ b <> s
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -351,28 +352,28 @@ tGetBlock THandle {connection = c, blockSize} =
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-smpServerHandshake c kh = do
+smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+smpServerHandshake c kh smpVRange = do
   let th@THandle {sessionId} = smpTHandle c
-  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
+  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
   getHandshake th >>= \case
     ClientHandshake {smpVersion, keyHash}
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
-      | smpVersion `isCompatible` supportedSMPVersions -> do
+      | smpVersion `isCompatible` smpVRange -> do
         pure (th :: THandle c) {thVersion = smpVersion}
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
-smpClientHandshake c keyHash = do
+smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+smpClientHandshake c keyHash smpVRange = do
   let th@THandle {sessionId} = smpTHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
   if sessionId /= sessId
     then throwE TEBadSession
-    else case smpVersionRange `compatibleVersion` supportedSMPVersions of
+    else case smpVersionRange `compatibleVersion` smpVRange of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
         pure (th :: THandle c) {thVersion = smpVersion}

src/Simplex/Messaging/Transport/Server.hs

@@ -12,20 +12,22 @@ module Simplex.Messaging.Transport.Server
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX
 import Data.Default (def)
-import Data.Set (Set)
-import qualified Data.Set as S
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import Network.Socket
 import qualified Network.TLS as T
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Util (catchAll_)
 import System.Exit (exitFailure)
+import System.Mem.Weak (Weak, deRefWeak)
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -36,37 +38,30 @@ import UnliftIO.STM
 runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
 runTransportServer started port serverParams server = do
   u <- askUnliftIO
-  liftIO $ do
-    clients <- newTVarIO S.empty
+  liftIO . runTCPServer started port $ \conn ->
     E.bracket
-      (startTCPServer started port)
-      (closeServer started clients)
-      $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
-        -- catchAll_ is needed here in case the connection was closed earlier
-        tid <- forkFinally (connectClient u conn) (const . liftIO $ gracefulClose conn 5000 `catchAll_` pure ())
-        atomically . modifyTVar' clients $ S.insert tid
-  where
-    connectClient :: UnliftIO m -> Socket -> IO ()
-    connectClient u conn =
-      E.bracket
-        (connectTLS serverParams conn >>= getServerConnection)
-        closeConnection
-        (unliftIO u . server)
+      (connectTLS serverParams conn >>= getServerConnection)
+      closeConnection
+      (unliftIO u . server)
 
--- | Run TCP server without TLS - only used in SimpleX Chat
+-- | Run TCP server without TLS
 runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
 runTCPServer started port server = do
-  clients <- newTVarIO S.empty
+  clients <- atomically TM.empty
+  clientId <- newTVarIO 0
   E.bracket
     (startTCPServer started port)
     (closeServer started clients)
     $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
-      tid <- forkFinally (server conn) (const $ gracefulClose conn 5000)
-      atomically . modifyTVar' clients $ S.insert tid
+      -- catchAll_ is needed here in case the connection was closed earlier
+      cId <- atomically $ stateTVar clientId $ \cId -> (cId + 1, cId + 1)
+      let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
+      tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
+      atomically $ TM.insert cId tId clients
 
-closeServer :: TMVar Bool -> TVar (Set ThreadId) -> Socket -> IO ()
+closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
 closeServer started clients sock = do
-  readTVarIO clients >>= mapM_ killThread
+  readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
   close sock
   void . atomically $ tryPutTMVar started False
 

src/Simplex/Messaging/Util.hs

@@ -78,3 +78,7 @@ catchAll = E.catch
 catchAll_ :: IO a -> IO a -> IO a
 catchAll_ a = catchAll a . const
 {-# INLINE catchAll_ #-}
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe = either (const Nothing) Just
+{-# INLINE eitherToMaybe #-}

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.21
+resolver: lts-18.28
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -38,8 +38,8 @@ extra-deps:
   - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
   - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
-# below dependancies are to update Aeson to 2.0.3
+  - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987
+  # below dependancies are to update Aeson to 2.0.3
   - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
   - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
   - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005
@@ -53,7 +53,6 @@ extra-deps:
   #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e
   #   subdirs:
   #     - core
-
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

tests/AgentTests.hs

@@ -12,6 +12,7 @@ module AgentTests (agentTests) where
 import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
+import AgentTests.NotificationTests (notificationTests)
 import AgentTests.SQLiteTests (storeTests)
 import AgentTests.SchemaDump (schemaDumpTest)
 import Control.Concurrent
@@ -28,6 +29,8 @@ import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
 import Simplex.Messaging.Util (bshow)
 import System.Directory (removeFile)
+import System.Posix.Files (stdFileMode)
+import System.Posix.Semaphore (OpenSemFlags (..), semOpen, semPost, semThreadWait)
 import System.Timeout
 import Test.Hspec
 
@@ -36,10 +39,12 @@ agentTests (ATransport t) = do
   describe "Connection request" connectionRequestTests
   describe "Double ratchet tests" doubleRatchetTests
   describe "Functional API" $ functionalAPITests (ATransport t)
+  describe "Notification tests" $ notificationTests (ATransport t)
   describe "SQLite store" storeTests
   describe "SQLite schema dump" schemaDumpTest
   describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection" $ do
+    it "test semaphore" testSemaphore
     it "should connect via one server and one agent" $
       smpAgentTest2_1_1 $ testDuplexConnection t
     it "should connect via one server and one agent (random IDs)" $
@@ -117,7 +122,13 @@ h #:# err = tryGet `shouldReturn` ()
         _ -> return ()
 
 pattern Msg :: MsgBody -> ACommand 'Agent
-pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
+pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
+
+testSemaphore :: IO ()
+testSemaphore = do
+  sem <- semOpen "/test" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 1
+  semThreadWait sem
+  semPost sem
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
@@ -130,25 +141,25 @@ testDuplexConnection _ alice bob = do
   bob <# ("", "alice", CON)
   alice <# ("", "bob", CON)
   -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
-  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 5)
-  alice <# ("", "bob", SENT 5)
+  alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 4)
+  alice <# ("", "bob", SENT 4)
   bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-  bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
-  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 6)
-  alice <# ("", "bob", SENT 6)
+  bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
+  alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
+  alice <# ("", "bob", SENT 5)
   bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
-  bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 7)
-  bob <# ("", "alice", SENT 7)
+  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
+  bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
-  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 8)
-  bob <# ("", "alice", SENT 8)
+  alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
+  bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
+  bob <# ("", "alice", SENT 7)
   alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
-  alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
+  alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
-  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 9)
-  bob <# ("", "alice", MERR 9 (SMP AUTH))
+  bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 8)
+  bob <# ("", "alice", MERR 8 (SMP AUTH))
   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
   alice #:# "nothing else should be delivered to alice"
 
@@ -163,25 +174,25 @@ testDuplexConnRandomIds _ alice bob = do
   bob <# ("", aliceConn, INFO "alice's connInfo")
   bob <# ("", aliceConn, CON)
   alice <# ("", bobConn, CON)
-  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 5)
-  alice <# ("", bobConn, SENT 5)
+  alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, MID 4)
+  alice <# ("", bobConn, SENT 4)
   bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
-  bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
-  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 6)
-  alice <# ("", bobConn, SENT 6)
+  bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
+  alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 5)
+  alice <# ("", bobConn, SENT 5)
   bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
-  bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
-  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 7)
-  bob <# ("", aliceConn, SENT 7)
+  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
+  bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 6)
+  bob <# ("", aliceConn, SENT 6)
   alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
-  alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
-  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 8)
-  bob <# ("", aliceConn, SENT 8)
+  alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
+  bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 7)
+  bob <# ("", aliceConn, SENT 7)
   alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
-  alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
+  alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
   alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
-  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 9)
-  bob <# ("", aliceConn, MERR 9 (SMP AUTH))
+  bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, MID 8)
+  bob <# ("", aliceConn, MERR 8 (SMP AUTH))
   alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
   alice #:# "nothing else should be delivered to alice"
 
@@ -198,10 +209,10 @@ testContactConnection _ alice bob tom = do
   alice <# ("", "bob", INFO "bob's connInfo 2")
   alice <# ("", "bob", CON)
   bob <# ("", "alice", CON)
-  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 5)
-  alice <# ("", "bob", SENT 5)
+  alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", MID 4)
+  alice <# ("", "bob", SENT 4)
   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
-  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
+  bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
   tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
   ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
@@ -211,10 +222,10 @@ testContactConnection _ alice bob tom = do
   alice <# ("", "tom", INFO "tom's connInfo 2")
   alice <# ("", "tom", CON)
   tom <# ("", "alice", CON)
-  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 5)
-  alice <# ("", "tom", SENT 5)
+  alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", MID 4)
+  alice <# ("", "tom", SENT 4)
   tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
-  tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
+  tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
 
 testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testContactConnRandomIds _ alice bob = do
@@ -234,10 +245,10 @@ testContactConnRandomIds _ alice bob = do
   alice <# ("", bobConn, CON)
   bob <# ("", aliceConn, CON)
 
-  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 5)
-  alice <# ("", bobConn, SENT 5)
+  alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, MID 4)
+  alice <# ("", bobConn, SENT 4)
   bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
-  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
+  bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
 testRejectContactRequest _ alice bob = do
@@ -254,20 +265,20 @@ testRejectContactRequest _ alice bob = do
 testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testSubscription _ alice1 alice2 bob = do
   (alice1, "alice") `connect` (bob, "bob")
-  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 5)
-  bob <# ("", "alice", SENT 5)
+  bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4)
+  bob <# ("", "alice", SENT 4)
   alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
-  alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
-  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 6)
-  bob <# ("", "alice", SENT 6)
+  alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
+  bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5)
+  bob <# ("", "alice", SENT 5)
   alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-  alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
+  alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
   alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
   alice1 <# ("", "bob", END)
-  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 7)
-  bob <# ("", "alice", SENT 7)
+  bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
   alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-  alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
+  alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
   alice1 #:# "nothing else should be delivered to alice1"
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
@@ -283,23 +294,23 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
 testMsgDeliveryServerRestart t alice bob = do
   withServer $ do
     connect (alice, "alice") (bob, "bob")
-    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 5)
-    bob <# ("", "alice", SENT 5)
+    bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", MID 4)
+    bob <# ("", "alice", SENT 4)
     alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-    alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
+    alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
   let server = (SMPServer "localhost" testPort2 testKeyHash)
   alice <# ("", "", DOWN server ["bob"])
-  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 6)
+  bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
-    bob <# ("", "alice", SENT 6)
+    bob <# ("", "alice", SENT 5)
     alice <# ("", "", UP server ["bob"])
     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-    alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
+    alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
 
   removeFile testStoreLogFile
   where
@@ -314,7 +325,7 @@ testServerConnectionAfterError t _ = do
 
       bob <# ("", "", DOWN server ["alice"])
       alice <# ("", "", DOWN server ["bob"])
-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
+      alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
       alice #:# "nothing else delivered before the server is restarted"
       bob #:# "nothing else delivered before the server is restarted"
 
@@ -323,13 +334,13 @@ testServerConnectionAfterError t _ = do
       bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
       alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
       withServer $ do
-        alice <# ("", "bob", SENT 5)
+        alice <# ("", "bob", SENT 4)
         bob <# ("", "", UP server ["alice"])
         bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-        bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
+        bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
         alice <# ("", "", UP server ["bob"])
-        alice #: ("1", "bob", "SEND 11\nhello again") #> ("1", "bob", MID 6)
-        alice <# ("", "bob", SENT 6)
+        alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
+        alice <# ("", "bob", SENT 5)
         bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
 
   removeFile testStoreLogFile
@@ -349,14 +360,14 @@ testMsgDeliveryAgentRestart t bob = do
   withAgent $ \alice -> do
     withServer $ do
       connect (bob, "bob") (alice, "alice")
-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
-      alice <# ("", "bob", SENT 5)
+      alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
+      alice <# ("", "bob", SENT 4)
       bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-      bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
+      bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
       bob #:# "nothing else delivered before the server is down"
 
     bob <# ("", "", DOWN server ["alice"])
-    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 6)
+    alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
     alice #:# "nothing else delivered before the server is restarted"
     bob #:# "nothing else delivered before the server is restarted"
 
@@ -366,11 +377,11 @@ testMsgDeliveryAgentRestart t bob = do
       alice <#= \case
         (corrId, "bob", cmd) ->
           (corrId == "3" && cmd == OK)
-            || (corrId == "" && cmd == SENT 6)
+            || (corrId == "" && cmd == SENT 5)
         _ -> False
       bob <# ("", "", UP server ["alice"])
       bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
-      bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
+      bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
   removeFile testDB
@@ -394,15 +405,15 @@ testConcurrentMsgDelivery _ alice bob = do
 
   -- the first connection should not be blocked by the second one
   sendMessage (alice, "alice") (bob, "bob") "hello"
-  -- alice #: ("2", "bob", "SEND :hello") #> ("2", "bob", MID 1)
+  -- alice #: ("2", "bob", "SEND F :hello") #> ("2", "bob", MID 1)
   -- alice <# ("", "bob", SENT 1)
   -- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
   -- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
-  bob <# ("", "alice", SENT 6)
+  bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5)
+  bob <# ("", "alice", SENT 5)
   -- if delivery is blocked it won't go further
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
+  alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
 
 testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
 testMsgDeliveryQuotaExceeded _ alice bob = do
@@ -411,13 +422,13 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
   forM_ [1 .. 4 :: Int] $ \i -> do
     let corrId = bshow i
         msg = "message " <> bshow i
-    (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND :" <> msg)
+    (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
     alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
-  (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
+  (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota")
 
-  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 5)
+  alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
   -- if delivery is blocked it won't go further
-  alice <# ("", "bob2", SENT 5)
+  alice <# ("", "bob2", SENT 4)
 
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
@@ -432,10 +443,10 @@ connect (h1, name1) (h2, name2) = do
 
 sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
 sendMessage (h1, name1) (h2, name2) msg = do
-  ("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND :" <> msg)
+  ("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND F :" <> msg)
   name2' `shouldBe` name2
   h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
-  ("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} msg')) <- (h2 <#:)
+  ("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} _ msg')) <- (h2 <#:)
   name1' `shouldBe` name1
   msg' `shouldBe` msg
   h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False

tests/AgentTests/ConnectionRequestTests.hs

@@ -48,7 +48,7 @@ connReqData :: ConnReqUriData
 connReqData =
   ConnReqUriData
     { crScheme = simplexChat,
-      crAgentVRange = smpAgentVRange,
+      crAgentVRange = mkVersionRange 1 1,
       crSmpQueues = [queue]
     }
 
@@ -70,7 +70,7 @@ connectionRequest12 :: AConnectionRequestUri
 connectionRequest12 =
   ACR SCMInvitation $
     CRInvitationUri
-      connReqData {crAgentVRange = mkVersionRange 1 2, crSmpQueues = [queue, queue]}
+      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
       testE2ERatchetParams13
 
 connectionRequestTests :: Spec

tests/AgentTests/FunctionalAPITests.hs

@@ -6,21 +6,30 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
-module AgentTests.FunctionalAPITests (functionalAPITests) where
+module AgentTests.FunctionalAPITests
+  ( functionalAPITests,
+    get,
+    (##>),
+    (=##>),
+    pattern Msg,
+  )
+where
 
 import Control.Concurrent (threadDelay)
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Unlift
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPAgentClient
-import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
+import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
+import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ATransport (..))
+import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO
 
@@ -34,13 +43,33 @@ get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
 get c = atomically (readTBQueue $ subQ c)
 
 pattern Msg :: MsgBody -> ACommand 'Agent
-pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
+pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
+
+agentCfgV1 :: AgentConfig
+agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1}
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
   describe "Establishing duplex connection" $
     it "should connect via one server using SMP agent clients" $
       withSmpServer t testAgentClient
+  describe "Duplex connection between agent versions 1 and 2" $ do
+    it "should connect agent v1 to v1" $
+      withSmpServer t testAgentClientV1toV1
+    it "should connect agent v1 to v2" $
+      withSmpServer t testAgentClientV1toV2
+    it "should connect agent v2 to v1" $
+      withSmpServer t testAgentClientV2toV1
+  describe "Establish duplex connection via contact address" $
+    it "should connect via one server using SMP agent clients" $
+      withSmpServer t testAgentClientContact
+  describe "Duplex connection via contact address between agent versions 1 and 2" $ do
+    it "should connect agent v1 to v1" $
+      withSmpServer t testAgentClientContactV1toV1
+    it "should connect agent v1 to v2" $
+      withSmpServer t testAgentClientContactV1toV2
+    it "should connect agent v2 to v1" $
+      withSmpServer t testAgentClientContactV2toV1
   describe "Establishing connection asynchronously" $ do
     it "should connect with initiating client going offline" $
       withSmpServer t testAsyncInitiatingOffline
@@ -52,6 +81,9 @@ functionalAPITests t = do
       testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
+  describe "Duplicate message delivery" $
+    it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
+      testDuplicateMessage t
   describe "Inactive client disconnection" $ do
     it "should disconnect clients if it was inactive longer than TTL" $
       testInactiveClientDisconnected t
@@ -62,6 +94,52 @@ testAgentClient :: IO ()
 testAgentClient = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 3
+
+testAgentClientV1toV1 :: IO ()
+testAgentClientV1toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
+
+testAgentClientV1toV2 :: IO ()
+testAgentClientV1toV2 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
+
+testAgentClientV2toV1 :: IO ()
+testAgentClientV2toV1 = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientTest alice bob 4
+
+testAgentClientContact :: IO ()
+testAgentClientContact = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 3
+
+testAgentClientContactV1toV1 :: IO ()
+testAgentClientContactV1toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
+
+testAgentClientContactV1toV2 :: IO ()
+testAgentClientContactV1toV2 = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
+
+testAgentClientContactV2toV1 :: IO ()
+testAgentClientContactV2toV1 = do
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  runAgentClientContactTest alice bob 4
+
+runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientTest alice bob baseId = do
   Right () <- runExceptT $ do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
@@ -70,37 +148,77 @@ testAgentClient = do
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
-    -- message IDs 1 to 4 get assigned to control messages, so first MSG is assigned ID 5
-    5 <- sendMessage alice bobId "hello"
-    get alice ##> ("", bobId, SENT 5)
-    6 <- sendMessage alice bobId "how are you?"
-    get alice ##> ("", bobId, SENT 6)
+    -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
+    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT $ baseId + 1)
+    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 5
+    ackMessage bob aliceId $ baseId + 1
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 6
-    7 <- sendMessage bob aliceId "hello too"
-    get bob ##> ("", aliceId, SENT 7)
-    8 <- sendMessage bob aliceId "message 1"
-    get bob ##> ("", aliceId, SENT 8)
+    ackMessage bob aliceId $ baseId + 2
+    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId 7
+    ackMessage alice bobId $ baseId + 3
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId 8
+    ackMessage alice bobId $ baseId + 4
     suspendConnection alice bobId
-    9 <- sendMessage bob aliceId "message 2"
-    get bob ##> ("", aliceId, MERR 9 (SMP AUTH))
+    5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
+    get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
   pure ()
   where
-    noMessages :: AgentClient -> String -> Expectation
-    noMessages c err = tryGet `shouldReturn` ()
-      where
-        tryGet =
-          10000 `timeout` get c >>= \case
-            Just _ -> error err
-            _ -> return ()
+    msgId = subtract baseId
+
+runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientContactTest alice bob baseId = do
+  Right () <- runExceptT $ do
+    (_, qInfo) <- createConnection alice SCMContact
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    ("", _, REQ invId "bob's connInfo") <- get alice
+    bobId <- acceptContact alice invId "alice's connInfo"
+    ("", _, CONF confId "alice's connInfo") <- get bob
+    allowConnection bob aliceId confId "bob's connInfo"
+    get alice ##> ("", bobId, INFO "bob's connInfo")
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, CON)
+    -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
+    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT $ baseId + 1)
+    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+    ackMessage bob aliceId $ baseId + 1
+    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
+    ackMessage bob aliceId $ baseId + 2
+    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
+    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 3
+    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 4
+    suspendConnection alice bobId
+    5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
+    get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
+    deleteConnection alice bobId
+    liftIO $ noMessages alice "nothing else should be delivered to alice"
+  pure ()
+  where
+    msgId = subtract baseId
+
+noMessages :: AgentClient -> String -> Expectation
+noMessages c err = tryGet `shouldReturn` ()
+  where
+    tryGet =
+      10000 `timeout` get c >>= \case
+        Just _ -> error err
+        _ -> return ()
 
 testAsyncInitiatingOffline :: IO ()
 testAsyncInitiatingOffline = do
@@ -188,7 +306,8 @@ testAsyncServerOffline t = do
 
 testAsyncHelloTimeout :: IO ()
 testAsyncHelloTimeout = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
+  -- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
+  alice <- getSMPAgentClient agentCfgV1 initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
   Right () <- runExceptT $ do
     (_, cReq) <- createConnection alice SCMInvitation
@@ -197,6 +316,62 @@ testAsyncHelloTimeout = do
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
   pure ()
 
+testDuplicateMessage :: ATransport -> IO ()
+testDuplicateMessage t = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    Right (aliceId, bobId) <- runExceptT $ do
+      (bobId, qInfo) <- createConnection alice SCMInvitation
+      aliceId <- joinConnection bob qInfo "bob's connInfo"
+      ("", _, CONF confId "bob's connInfo") <- get alice
+      allowConnection alice bobId confId "alice's connInfo"
+      get alice ##> ("", bobId, CON)
+      get bob ##> ("", aliceId, INFO "alice's connInfo")
+      get bob ##> ("", aliceId, CON)
+      4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+      get alice ##> ("", bobId, SENT 4)
+      get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+      pure (aliceId, bobId)
+    disconnectAgentClient bob
+
+    -- if the agent user did not send ACK, the message will be delivered again
+    bob1 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    Right () <- runExceptT $ do
+      subscribeConnection bob1 aliceId
+      get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+      ackMessage bob1 aliceId 4
+      5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
+      get alice ##> ("", bobId, SENT 5)
+      get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
+
+    pure (aliceId, bobId, bob1)
+
+  get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+  get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+  -- commenting two lines below and uncommenting further two lines would also pass,
+  -- it is the scenario tested above, when the message was not acknowledged by the user
+  threadDelay 200000
+  Left (BROKER TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
+
+  disconnectAgentClient alice
+  disconnectAgentClient bob1
+
+  alice2 <- getSMPAgentClient agentCfg initAgentServers
+  bob2 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    Right () <- runExceptT $ do
+      subscribeConnection bob2 aliceId
+      subscribeConnection alice2 bobId
+      -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
+      -- ackMessage bob2 aliceId 5
+      -- message 2 is not delivered again, even though it was delivered to the agent
+      6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
+      get alice2 ##> ("", bobId, SENT 6)
+      get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
+    pure ()
+
 testInactiveClientDisconnected :: ATransport -> IO ()
 testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
@@ -237,11 +412,11 @@ testActiveClientNotDisconnected t = do
 
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings alice bobId bob aliceId = do
-  5 <- sendMessage alice bobId "hello"
-  get alice ##> ("", bobId, SENT 5)
+  4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+  get alice ##> ("", bobId, SENT 4)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId 5
-  6 <- sendMessage bob aliceId "hello too"
-  get bob ##> ("", aliceId, SENT 6)
+  ackMessage bob aliceId 4
+  5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
+  get bob ##> ("", aliceId, SENT 5)
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId 6
+  ackMessage alice bobId 5

tests/AgentTests/NotificationTests.hs

@@ -1,10 +1,15 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
 
+import AgentTests.FunctionalAPITests (get, (##>), (=##>), pattern Msg)
 import Control.Concurrent (threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
@@ -15,6 +20,7 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
+import SMPClient (withSmpServer)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
@@ -22,15 +28,16 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Protocol (ErrorType (AUTH))
+import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Util (tryE)
 import System.Directory (removeFile)
 import Test.Hspec
-import UnliftIO.STM
+import UnliftIO
 
 notificationTests :: ATransport -> Spec
 notificationTests t =
-  after_ (removeFile testDB) $
+  after_ (removeFile testDB) $ do
     describe "Managing notification tokens" $ do
       it "should register and verify notification token" $
         withAPNSMockServer $ \apns ->
@@ -44,6 +51,15 @@ notificationTests t =
       it "should re-register token when notification server is restarted" $ \_ ->
         withAPNSMockServer $ \apns ->
           testNtfTokenServerRestart t apns
+    describe "Managing notification subscriptions" $ do
+      it "should create notification subscription for existing connection" $ \_ ->
+        withSmpServer t $
+          withAPNSMockServer $ \apns ->
+            withNtfServer t $ testNotificationSubscriptionExistingConnection apns
+      it "should create notification subscription for new connection" $ \_ ->
+        withSmpServer t $
+          withAPNSMockServer $ \apns ->
+            withNtfServer t $ testNotificationSubscriptionNewConnection apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
@@ -125,7 +141,10 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     -- at this point the first token is still active
     NTActive <- checkNtfToken a tkn
     -- and the second is not yet verified
-    NTConfirmed <- checkNtfToken a' tkn
+    liftIO $ threadDelay 50000
+    r <- checkNtfToken a' tkn
+    liftIO . print $ "checkNtfToken a' tkn: " <> show r
+    unless (r == NTConfirmed) $ error "bad status"
     -- now the second token registration is verified
     verifyNtfToken a' tkn verification' nonce'
     -- the first registration is removed
@@ -165,3 +184,113 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
     NTActive <- checkNtfToken a' tkn
     enableNtfCron a' tkn 30
   pure ()
+
+testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
+testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    -- establish connection
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    ("", _, CONF confId "bob's connInfo") <- get alice
+    allowConnection alice bobId confId "alice's connInfo"
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, CON)
+    -- register notification token
+    let tkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken alice tkn
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
+      atomically $ readTBQueue apnsQ
+    verification <- ntfData .-> "verification"
+    nonce <- C.cbNonce <$> ntfData .-> "nonce"
+    liftIO $ sendApnsResponse APNSRespOk
+    verifyNtfToken alice tkn verification nonce
+    NTActive <- checkNtfToken alice tkn
+    -- send message
+    liftIO $ threadDelay 50000
+    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT $ baseId + 1)
+    messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 1
+    -- no unexpected notifications should follow
+    500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+      Nothing -> pure ()
+      _ -> error "unexpected notification"
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
+testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    -- alice registers notification token
+    let aliceTkn = DeviceToken PPApns "abcd"
+    NTRegistered <- registerNtfToken alice aliceTkn
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
+      atomically $ readTBQueue apnsQ
+    verification <- ntfData .-> "verification"
+    nonce <- C.cbNonce <$> ntfData .-> "nonce"
+    liftIO $ sendApnsResponse APNSRespOk
+    verifyNtfToken alice aliceTkn verification nonce
+    NTActive <- checkNtfToken alice aliceTkn
+    -- bob registers notification token
+    let bobTkn = DeviceToken PPApns "bcde"
+    NTRegistered <- registerNtfToken bob bobTkn
+    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
+      atomically $ readTBQueue apnsQ
+    verification' <- ntfData' .-> "verification"
+    nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
+    liftIO $ sendApnsResponse' APNSRespOk
+    verifyNtfToken bob bobTkn verification' nonce'
+    NTActive <- checkNtfToken bob bobTkn
+    -- establish connection
+    liftIO $ threadDelay 50000
+    (bobId, qInfo) <- createConnection alice SCMInvitation
+    liftIO $ threadDelay 500000
+    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    messageNotification apnsQ
+    ("", _, CONF confId "bob's connInfo") <- get alice
+    liftIO $ threadDelay 500000
+    allowConnection alice bobId confId "alice's connInfo"
+    messageNotification apnsQ
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
+    messageNotification apnsQ
+    get alice ##> ("", bobId, CON)
+    messageNotification apnsQ
+    get bob ##> ("", aliceId, CON)
+    -- bob sends message
+    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT $ baseId + 1)
+    messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 1
+    -- alice sends message
+    2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
+    messageNotification apnsQ
+    get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
+    ackMessage bob aliceId $ baseId + 2
+    -- no unexpected notifications should follow
+    500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+      Nothing -> pure ()
+      _ -> error "unexpected notification"
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
+messageNotification apnsQ = do
+  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+    Nothing -> error "no notification"
+    Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
+      _ <- ntfData .-> "checkMessage"
+      _ <- C.cbNonce <$> ntfData .-> "nonce"
+      liftIO $ sendApnsResponse APNSRespOk
+    _ -> error "bad notification"

tests/AgentTests/SQLiteTests.hs

@@ -27,6 +27,7 @@ import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Protocol as SMP
 import System.Random
 import Test.Hspec
 import UnliftIO.Directory (removeFile)
@@ -43,7 +44,7 @@ withStore2 = before connect2 . after (removeStore . fst)
     connect2 :: IO (SQLiteStore, SQLiteStore)
     connect2 = do
       s1 <- createStore
-      s2 <- connectSQLiteStore (dbFilePath s1) 4
+      s2 <- connectSQLiteStore (dbFilePath s1) Nothing
       pure (s1, s2)
 
 createStore :: IO SQLiteStore
@@ -51,7 +52,7 @@ createStore = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  createSQLiteStore (testDB <> show r) 4 Migrations.app True
+  createSQLiteStore (testDB <> show r) Nothing Migrations.app True
 
 removeStore :: SQLiteStore -> IO ()
 removeStore store = do
@@ -59,7 +60,7 @@ removeStore store = do
   removeFile $ dbFilePath store
   where
     close :: SQLiteStore -> IO ()
-    close st = mapM_ DB.close =<< atomically (flushTBQueue $ dbConnPool st)
+    close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
 
 returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation
 action `returnsResult` r = runExceptT action `shouldReturn` Right r
@@ -144,7 +145,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {connId = "conn1"}
+cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -165,7 +166,10 @@ rcvQueue1 =
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
       sndId = Just "2345",
-      status = New
+      status = New,
+      ntfPublicKey = Nothing,
+      ntfPrivateKey = Nothing,
+      notifierId = Nothing
     }
 
 sndQueue1 :: SndQueue
@@ -331,7 +335,10 @@ testUpgradeSndConnToDuplex =
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
               sndId = Just "4567",
-              status = New
+              status = New,
+              ntfPublicKey = Nothing,
+              ntfPrivateKey = Nothing,
+              notifierId = Nothing
             }
     upgradeSndConnToDuplex store "conn1" anotherRcvQueue
       `throwsError` SEBadConnType CRcv
@@ -398,6 +405,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
             broker = (brokerId, ts)
           },
       msgType = AM_A_MSG_,
+      msgFlags = SMP.noMsgFlags,
       msgBody = hw,
       internalHash,
       externalPrevSndHash = "hash_from_sender"
@@ -427,6 +435,7 @@ mkSndMsgData internalId internalSndId internalHash =
       internalSndId,
       internalTs = ts,
       msgType = AM_A_MSG_,
+      msgFlags = SMP.noMsgFlags,
       msgBody = hw,
       internalHash,
       prevMsgHash = internalHash

tests/AgentTests/SchemaDump.hs

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

tests/NtfClient.hs

@@ -18,8 +18,9 @@ import Control.Monad
 import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
 import Crypto.Random
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
@@ -42,6 +43,7 @@ import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.KeepAlive
+import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
@@ -63,7 +65,7 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testNtfClient client =
   runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
-    liftIO (runExceptT $ ntfClientHandshake h testKeyHash) >>= \case
+    liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -134,6 +136,9 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
       (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
+ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+ntfTest _ test' = runNtfTest test' `shouldReturn` ()
+
 data APNSMockRequest = APNSMockRequest
   { notification :: APNSNotification,
     sendApnsResponse :: APNSMockResponse -> IO ()
@@ -163,9 +168,16 @@ withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPN
 
 deriving instance Generic APNSAlertBody
 
-deriving instance FromJSON APNSAlertBody
+instance FromJSON APNSAlertBody where
+  parseJSON (J.Object v) = do
+    title <- v .: "title"
+    subtitle <- v .: "subtitle"
+    body <- v .: "body"
+    pure APNSAlertObject {title, subtitle, body}
+  parseJSON (J.String v) = pure $ APNSAlertText v
+  parseJSON invalid = JT.prependFailure "parsing Coord failed, " (JT.typeMismatch "Object" invalid)
 
-instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions
+instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions {J.rejectUnknownFields = True}
 
 deriving instance FromJSON APNSNotification
 
@@ -185,8 +197,11 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
             APNSRespError status reason ->
               sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason}
       case J.decodeStrict' reqBody of
-        Just notification -> atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
-        _ -> sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
+        Just notification ->
+          atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
+        _ -> do
+          putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show reqBody
+          sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
 closeAPNSMockServer :: APNSMockServer -> IO ()
 closeAPNSMockServer APNSMockServer {action, http2Server} = do

tests/NtfServerTests.hs

@@ -1,23 +1,46 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module NtfServerTests where
 
+import Control.Concurrent (threadDelay)
+import Control.Monad.Except (runExceptT)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
+import Data.Text.Encoding (encodeUtf8)
 import NtfClient
-import ServerTests (sampleDhPubKey, samplePubKey, sampleSig)
+import SMPClient as SMP
+import ServerTests
+  ( createAndSecureQueue,
+    sampleDhPubKey,
+    samplePubKey,
+    sampleSig,
+    signSendRecv,
+    (#==),
+    _SEND',
+    pattern Resp,
+  )
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol
+import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Protocol hiding (notification)
 import Simplex.Messaging.Transport
 import Test.Hspec
+import UnliftIO.STM
 
 ntfServerTests :: ATransport -> Spec
 ntfServerTests t = do
-  describe "notifications server protocol syntax" $ ntfSyntaxTests t
+  describe "Notifications server protocol syntax" $ ntfSyntaxTests t
+  describe "Notification subscriptions" $ testNotificationSubscription t
 
 ntfSyntaxTests :: ATransport -> Spec
 ntfSyntaxTests (ATransport t) = do
@@ -34,3 +57,71 @@ ntfSyntaxTests (ATransport t) = do
       (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
       Expectation
     command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
+
+pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission NtfResponse
+pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
+
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
+sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
+  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
+  Right () <- tPut h (sgn, t)
+  tGet h
+
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
+signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
+  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
+  Right sig <- runExceptT $ C.sign pk t
+  Right () <- tPut h (Just sig, t)
+  tGet h
+
+(.->) :: J.Value -> J.Key -> Either String ByteString
+v .-> key =
+  let J.Object o = v
+   in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
+
+testNotificationSubscription :: ATransport -> Spec
+testNotificationSubscription (ATransport t) =
+  it "should create notification subscription and notify when message is received" $ do
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
+    (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519
+    (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+    let tkn = DeviceToken PPApns "abcd"
+    withAPNSMockServer $ \APNSMockServer {apnsQ} ->
+      smpTest2 t $ \rh sh ->
+        ntfTest t $ \nh -> do
+          -- create queue
+          (sId, rId, rKey, _dhShared) <- createAndSecureQueue rh sPub
+          -- register and verify token
+          RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", TNEW $ NewNtfTkn tkn tknPub dhPub)
+          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <-
+            atomically $ readTBQueue apnsQ
+          send APNSRespOk
+          let dhSecret = C.dh' ntfDh dhPriv
+              Right verification = ntfData .-> "verification"
+              Right nonce = C.cbNonce <$> ntfData .-> "nonce"
+              Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
+          RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
+          RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
+          -- enable queue notifications
+          Resp "3" _ (NID nId) <- signSendRecv rh rKey ("3", rId, NKEY nPub)
+          let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
+              q = SMPQueueNtf srv nId
+          RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey)
+          -- send message
+          threadDelay 50000
+          Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello")
+          -- receive notification
+          APNSMockRequest {notification, sendApnsResponse = send'} <- atomically $ readTBQueue apnsQ
+          let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification
+              Right checkMessage = ntfData' .-> "checkMessage"
+              Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
+              Right smpQueueURI = C.cbDecrypt dhSecret nonce' checkMessage
+          smpQueueURI `shouldBe` strEncode srv <> "/" <> strEncode nId
+          send' APNSRespOk
+          -- receive message
+          let dec _nonce = C.cbDecrypt _dhShared (C.cbNonce _nonce)
+          Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh
+          (dec mId1 msg1, Right "hello") #== "delivered from queue"
+          Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
+          pure ()

tests/SMPAgentClient.hs

@@ -171,6 +171,7 @@ agentCfg =
     { tcpPort = agentTestPort,
       tbqSize = 1,
       dbFile = testDB,
+      dbSemName = Nothing, -- Just "/simplex-agent",
       smpCfg =
         defaultClientConfig
           { qSize = 1,
@@ -183,6 +184,7 @@ agentCfg =
             defaultTransport = (ntfTestPort, transport @TLS)
           },
       reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
+      ntfWorkerThrottle = 1000,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"

tests/SMPClient.hs

@@ -43,10 +43,13 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 testStoreLogFile :: FilePath
 testStoreLogFile = "tests/tmp/smp-server-store.log"
 
+testStoreMsgsFile :: FilePath
+testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
+
 testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testSMPClient client =
   runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
-    liftIO (runExceptT $ smpClientHandshake h testKeyHash) >>= \case
+    liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -60,6 +63,7 @@ cfg =
       queueIdBytes = 24,
       msgIdBytes = 24,
       storeLogFile = Nothing,
+      storeMsgsFile = Nothing,
       allowNewQueues = True,
       messageExpiration = Just defaultMessageExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
@@ -67,9 +71,13 @@ cfg =
       logStatsStartTime = 0,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
+      certificateFile = "tests/fixtures/server.crt",
+      smpServerVRange = supportedSMPServerVRange
     }
 
+withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
+
 withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
 withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile}
 

tests/ServerTests.hs

@@ -41,7 +41,10 @@ serverTests t@(ATransport t') = do
   describe "SMP messages" $ do
     describe "duplex communication over 2 SMP connections" $ testDuplex t
     describe "switch subscription to another TCP connection" $ testSwitchSub t
+    describe "GET command" $ testGetCommand t'
+    describe "GET & SUB commands" $ testGetSubCommands t'
   describe "Store log" $ testWithStoreLog t
+  describe "Restore messages" $ testRestoreMessages t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
@@ -56,14 +59,14 @@ pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
 pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
 
 sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
-sendRecv h@THandle {sessionId} (sgn, corrId, qId, cmd) = do
-  let t = encodeTransmission sessionId (CorrId corrId, qId, cmd)
+sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
+  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right () <- tPut h (sgn, t)
   tGet h
 
 signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
-signSendRecv h@THandle {sessionId} pk (corrId, qId, cmd) = do
-  let t = encodeTransmission sessionId (CorrId corrId, qId, cmd)
+signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
+  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right sig <- runExceptT $ C.sign pk t
   Right () <- tPut h (Just sig, t)
   tGet h
@@ -71,6 +74,12 @@ signSendRecv h@THandle {sessionId} pk (corrId, qId, cmd) = do
 (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
 (actual, expected) #== message = assertEqual message expected actual
 
+_SEND :: MsgBody -> Command 'Sender
+_SEND = SEND noMsgFlags
+
+_SEND' :: MsgBody -> Command 'Sender
+_SEND' = SEND MsgFlags {notification = True}
+
 testCreateSecure :: ATransport -> Spec
 testCreateSecure (ATransport t) =
   it "should create (NEW) and secure (KEY) queue" $
@@ -81,21 +90,21 @@ testCreateSecure (ATransport t) =
       let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
       (rId1, "") #== "creates queue"
 
-      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, SEND "hello")
+      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, _SEND "hello")
       (ok1, OK) #== "accepts unsigned SEND"
       (sId1, sId) #== "same queue ID in response 1"
 
-      Resp "" _ (MSG mId1 _ msg1) <- tGet h
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet h
       (dec mId1 msg1, Right "hello") #== "delivers message"
 
-      Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK)
+      Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
       (ok4, OK) #== "replies OK when message acknowledged if no more messages"
 
-      Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK)
+      Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1)
       (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
 
       (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
-      Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, SEND "hello")
+      Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello")
       (err1, ERR AUTH) #== "rejects signed SEND"
       (sId2, sId) #== "same queue ID in response 2"
 
@@ -112,16 +121,16 @@ testCreateSecure (ATransport t) =
       Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
       (err4, ERR AUTH) #== "rejects KEY if already secured"
 
-      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, SEND "hello again")
+      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
       (ok3, OK) #== "accepts signed SEND"
 
-      Resp "" _ (MSG mId2 _ msg2) <- tGet h
+      Resp "" _ (MSG mId2 _ _ msg2) <- tGet h
       (dec mId2 msg2, Right "hello again") #== "delivers message 2"
 
-      Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK)
+      Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
       (ok5, OK) #== "replies OK when message acknowledged 2"
 
-      Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, SEND "hello")
+      Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, _SEND "hello")
       (err5, ERR AUTH) #== "rejects unsigned SEND"
 
 testCreateDelete :: ATransport -> Spec
@@ -138,13 +147,13 @@ testCreateDelete (ATransport t) =
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
       (ok1, OK) #== "secures queue"
 
-      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, SEND "hello")
+      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, _SEND "hello")
       (ok2, OK) #== "accepts signed SEND"
 
-      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, SEND "hello 2")
+      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello 2")
       (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
 
-      Resp "" _ (MSG mId1 _ msg1) <- tGet rh
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh
       (dec mId1 msg1, Right "hello") #== "delivers message"
 
       Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)
@@ -157,16 +166,16 @@ testCreateDelete (ATransport t) =
       (ok3, OK) #== "suspends queue"
       (rId2, rId) #== "same queue ID in response 2"
 
-      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, SEND "hello")
+      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello")
       (err3, ERR AUTH) #== "rejects signed SEND"
 
-      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, SEND "hello")
+      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, _SEND "hello")
       (err4, ERR AUTH) #== "reject unsigned SEND too"
 
       Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)
       (ok4, OK) #== "accepts OFF when suspended"
 
-      Resp "cdab" _ (MSG mId2 _ msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
+      Resp "cdab" _ (MSG mId2 _ _ msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
       (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
 
       Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)
@@ -179,13 +188,13 @@ testCreateDelete (ATransport t) =
       (ok6, OK) #== "deletes queue"
       (rId3, rId) #== "same queue ID in response 3"
 
-      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, SEND "hello")
+      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, _SEND "hello")
       (err7, ERR AUTH) #== "rejects signed SEND when deleted"
 
-      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, SEND "hello")
+      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, _SEND "hello")
       (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted"
 
-      Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK)
+      Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK "")
       (err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted"
 
       Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF)
@@ -232,11 +241,11 @@ testDuplex (ATransport t) =
       -- aSnd ID is passed to Bob out-of-band
 
       (bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448
-      Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, SEND $ "key " <> strEncode bsPub)
+      Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
       -- "key ..." is ad-hoc, not a part of SMP protocol
 
-      Resp "" _ (MSG mId1 _ msg1) <- tGet alice
-      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK)
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet alice
+      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId1)
       Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
       (bobKey, strEncode bsPub) #== "key received from Bob"
       Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub)
@@ -245,34 +254,34 @@ testDuplex (ATransport t) =
       (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub)
       let bDec nonce = C.cbDecrypt (C.dh' bSrvDh bDhPriv) (C.cbNonce nonce)
-      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, SEND $ "reply_id " <> encode bSnd)
+      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
       -- "reply_id ..." is ad-hoc, not a part of SMP protocol
 
-      Resp "" _ (MSG mId2 _ msg2) <- tGet alice
-      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK)
+      Resp "" _ (MSG mId2 _ _ msg2) <- tGet alice
+      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
       Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
       (bId, encode bSnd) #== "reply queue ID received from Bob"
 
       (asPub, asKey) <- C.generateSignatureKeyPair C.SEd448
-      Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, SEND $ "key " <> strEncode asPub)
+      Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
       -- "key ..." is ad-hoc, not a part of  SMP protocol
 
-      Resp "" _ (MSG mId3 _ msg3) <- tGet bob
-      Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK)
+      Resp "" _ (MSG mId3 _ _ msg3) <- tGet bob
+      Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK mId3)
       Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
       (aliceKey, strEncode asPub) #== "key received from Alice"
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, KEY asPub)
 
-      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, SEND "hi alice")
+      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
 
-      Resp "" _ (MSG mId4 _ msg4) <- tGet alice
-      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK)
+      Resp "" _ (MSG mId4 _ _ msg4) <- tGet alice
+      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK mId4)
       (aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
 
-      Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, SEND "how are you bob")
+      Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, _SEND "how are you bob")
 
-      Resp "" _ (MSG mId5 _ msg5) <- tGet bob
-      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK)
+      Resp "" _ (MSG mId5 _ _ msg5) <- tGet bob
+      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
       (bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
 
 testSwitchSub :: ATransport -> Spec
@@ -283,38 +292,105 @@ testSwitchSub (ATransport t) =
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub)
       let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
-      Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, SEND "test1")
+      Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
       (ok1, OK) #== "sent test message 1"
-      Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, SEND "test2, no ACK")
+      Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, _SEND "test2, no ACK")
       (ok2, OK) #== "sent test message 2"
 
-      Resp "" _ (MSG mId1 _ msg1) <- tGet rh1
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh1
       (dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
-      Resp "abcd" _ (MSG mId2 _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK)
+      Resp "abcd" _ (MSG mId2 _ _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
       (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
 
-      Resp "bcda" _ (MSG mId2' _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)
+      Resp "bcda" _ (MSG mId2' _ _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)
       (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
-      Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK)
+      Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
 
       Resp "" _ end <- tGet rh1
       (end, END) #== "unsubscribed the 1st TCP connection"
 
-      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, SEND "test3")
+      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, _SEND "test3")
 
-      Resp "" _ (MSG mId3 _ msg3) <- tGet rh2
+      Resp "" _ (MSG mId3 _ _ msg3) <- tGet rh2
       (dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
 
-      Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK)
+      Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK mId3)
       (err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection"
 
-      Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK)
+      Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
       (ok3, OK) #== "accepts ACK from the 2nd TCP connection"
 
       1000 `timeout` tGet @BrokerMsg rh1 >>= \case
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
 
+testGetCommand :: forall c. Transport c => TProxy c -> Spec
+testGetCommand t =
+  it "should retrieve messages from the queue using GET command" $ do
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    smpTest t $ \sh -> do
+      queue <- newEmptyTMVarIO
+      testSMPClient @c $ \rh ->
+        atomically . putTMVar queue =<< createAndSecureQueue rh sPub
+      testSMPClient @c $ \rh -> do
+        (sId, rId, rKey, dhShared) <- atomically $ takeTMVar queue
+        let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
+        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello")
+        Resp "2" _ (MSG mId1 _ _ msg1) <- signSendRecv rh rKey ("2", rId, GET)
+        (dec mId1 msg1, Right "hello") #== "retrieved from queue"
+        Resp "3" _ OK <- signSendRecv rh rKey ("3", rId, ACK mId1)
+        Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET)
+        pure ()
+
+testGetSubCommands :: forall c. Transport c => TProxy c -> Spec
+testGetSubCommands t =
+  it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    smpTest3 t $ \rh1 rh2 sh -> do
+      (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub
+      let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
+      Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
+      Resp "1a" _ OK <- signSendRecv sh sKey ("1a", sId, _SEND "hello 2")
+      Resp "1b" _ OK <- signSendRecv sh sKey ("1b", sId, _SEND "hello 3")
+      Resp "1c" _ OK <- signSendRecv sh sKey ("1c", sId, _SEND "hello 4")
+      -- both get the same if not ACK'd
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh1
+      Resp "2" _ (MSG mId1' _ _ msg1') <- signSendRecv rh2 rKey ("2", rId, GET)
+      (dec mId1 msg1, Right "hello 1") #== "received from queue via SUB"
+      (dec mId1' msg1', Right "hello 1") #== "retrieved from queue with GET"
+      mId1 `shouldBe` mId1'
+      msg1 `shouldBe` msg1'
+      -- subscriber cannot GET, getter cannot SUB
+      Resp "3" _ (ERR (CMD PROHIBITED)) <- signSendRecv rh1 rKey ("3", rId, GET)
+      Resp "3a" _ (ERR (CMD PROHIBITED)) <- signSendRecv rh2 rKey ("3a", rId, SUB)
+      -- ACK for SUB delivers the next message
+      Resp "4" _ (MSG mId2 _ _ msg2) <- signSendRecv rh1 rKey ("4", rId, ACK mId1)
+      (dec mId2 msg2, Right "hello 2") #== "received from queue via SUB"
+      -- bad msgId returns error
+      Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK "1234")
+      -- already ACK'd by subscriber, but still returns OK when msgId matches
+      Resp "5a" _ OK <- signSendRecv rh2 rKey ("5a", rId, ACK mId1)
+      -- msg2 is not lost - even if subscriber does not ACK it, it is delivered to getter
+      Resp "6" _ (MSG mId2' _ _ msg2') <- signSendRecv rh2 rKey ("6", rId, GET)
+      (dec mId2' msg2', Right "hello 2") #== "retrieved from queue with GET"
+      mId2 `shouldBe` mId2'
+      msg2 `shouldBe` msg2'
+      -- getter ACK returns OK, even though there is the next message
+      Resp "7" _ OK <- signSendRecv rh2 rKey ("7", rId, ACK mId2')
+      Resp "8" _ (MSG mId3 _ _ msg3) <- signSendRecv rh2 rKey ("8", rId, GET)
+      (dec mId3 msg3, Right "hello 3") #== "retrieved from queue with GET"
+      -- subscriber ACK does not lose message
+      Resp "9" _ (MSG mId3' _ _ msg3') <- signSendRecv rh1 rKey ("9", rId, ACK mId2')
+      (dec mId3' msg3', Right "hello 3") #== "retrieved from queue with GET"
+      mId3 `shouldBe` mId3'
+      msg3 `shouldBe` msg3'
+      Resp "10" _ (MSG mId4 _ _ msg4) <- signSendRecv rh1 rKey ("10", rId, ACK mId3)
+      (dec mId4 msg4, Right "hello 4") #== "retrieved from queue with GET"
+      Resp "11" _ OK <- signSendRecv rh1 rKey ("11", rId, ACK mId4)
+      -- no more messages for getter too
+      Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
+      pure ()
+
 testWithStoreLog :: ATransport -> Spec
 testWithStoreLog at@(ATransport t) =
   it "should store simplex queues to log and restore them after server restart" $ do
@@ -338,26 +414,26 @@ testWithStoreLog at@(ATransport t) =
         writeTVar senderId1 sId1
         writeTVar notifierId nId
       Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
-      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")
-      Resp "" _ (MSG mId1 _ msg1) <- tGet h
+      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet h
       (C.cbDecrypt dhShared (C.cbNonce mId1) msg1, Right "hello") #== "delivered from queue 1"
       Resp "" _ NMSG <- tGet h1
 
       (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
       atomically $ writeTVar senderId2 sId2
-      Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too")
-      Resp "" _ (MSG mId2 _ msg2) <- tGet h
+      Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
+      Resp "" _ (MSG mId2 _ _ msg2) <- tGet h
       (C.cbDecrypt dhShared2 (C.cbNonce mId2) msg2, Right "hello too") #== "delivered from queue 2"
 
       Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
       pure ()
 
-    logSize `shouldReturn` 6
+    logSize testStoreLogFile `shouldReturn` 6
 
     withSmpServerThreadOn at testPort . runTest t $ \h -> do
       sId1 <- readTVarIO senderId1
       -- fails if store log is disabled
-      Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")
+      Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello")
       pure ()
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
@@ -368,16 +444,16 @@ testWithStoreLog at@(ATransport t) =
       sId1 <- readTVarIO senderId1
       nId <- readTVarIO notifierId
       Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
-      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")
-      Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
+      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
+      Resp "cdab" _ (MSG mId3 _ _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
       (C.cbDecrypt dh1 (C.cbNonce mId3) msg3, Right "hello") #== "delivered from restored queue"
       Resp "" _ NMSG <- tGet h1
       -- this queue is removed - not restored
       sId2 <- readTVarIO senderId2
-      Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too")
+      Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
       pure ()
 
-    logSize `shouldReturn` 1
+    logSize testStoreLogFile `shouldReturn` 1
     removeFile testStoreLogFile
   where
     runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
@@ -388,11 +464,79 @@ testWithStoreLog at@(ATransport t) =
     runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
-    logSize :: IO Int
-    logSize =
-      try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case
-        Right l -> pure l
-        Left (_ :: SomeException) -> logSize
+logSize :: FilePath -> IO Int
+logSize f =
+  try (length . B.lines <$> B.readFile f) >>= \case
+    Right l -> pure l
+    Left (_ :: SomeException) -> logSize f
+
+testRestoreMessages :: ATransport -> Spec
+testRestoreMessages at@(ATransport t) =
+  it "should store messages on exit and restore on start" $ do
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    recipientId <- newTVarIO ""
+    recipientKey <- newTVarIO Nothing
+    dhShared <- newTVarIO Nothing
+    senderId <- newTVarIO ""
+
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
+      runClient t $ \h1 -> do
+        (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
+        atomically $ do
+          writeTVar recipientId rId
+          writeTVar recipientKey $ Just rKey
+          writeTVar dhShared $ Just dh
+          writeTVar senderId sId
+        Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
+        Resp "" _ (MSG mId1 _ _ msg1) <- tGet h1
+        Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
+        (C.cbDecrypt dh (C.cbNonce mId1) msg1, Right "hello") #== "message delivered"
+      -- messages below are delivered after server restart
+      sId <- readTVarIO senderId
+      Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
+      Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
+      Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
+      pure ()
+
+    logSize testStoreLogFile `shouldReturn` 2
+    logSize testStoreMsgsFile `shouldReturn` 3
+
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
+      rId <- readTVarIO recipientId
+      Just rKey <- readTVarIO recipientKey
+      Just dh <- readTVarIO dhShared
+      Resp "2" _ (MSG mId2 _ _ msg2) <- signSendRecv h rKey ("2", rId, SUB)
+      (C.cbDecrypt dh (C.cbNonce mId2) msg2, Right "hello 2") #== "restored message delivered"
+      Resp "3" _ (MSG mId3 _ _ msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
+      (C.cbDecrypt dh (C.cbNonce mId3) msg3, Right "hello 3") #== "restored message delivered"
+      Resp "4" _ (MSG mId4 _ _ msg4) <- signSendRecv h rKey ("4", rId, ACK mId3)
+      (C.cbDecrypt dh (C.cbNonce mId4) msg4, Right "hello 4") #== "restored message delivered"
+
+    logSize testStoreLogFile `shouldReturn` 1
+    -- the last message is not removed because it was not ACK'd
+    logSize testStoreMsgsFile `shouldReturn` 1
+
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
+      rId <- readTVarIO recipientId
+      Just rKey <- readTVarIO recipientKey
+      Just dh <- readTVarIO dhShared
+      Resp "4" _ (MSG mId4 _ _ msg4) <- signSendRecv h rKey ("4", rId, SUB)
+      Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4)
+      (C.cbDecrypt dh (C.cbNonce mId4) msg4, Right "hello 4") #== "restored message delivered"
+
+    logSize testStoreLogFile `shouldReturn` 1
+    logSize testStoreMsgsFile `shouldReturn` 0
+
+    removeFile testStoreLogFile
+    removeFile testStoreMsgsFile
+  where
+    runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
+    runTest _ test' server = do
+      testSMPClient test' `shouldReturn` ()
+      killThread server
+
+    runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+    runClient _ test' = testSMPClient test' `shouldReturn` ()
 
 createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
 createAndSecureQueue h sPub = do
@@ -432,11 +576,11 @@ testTiming (ATransport t) =
       (sPub, sKey) <- generateKeys goodKeySize
       Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
 
-      Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, SEND "hello")
-      Resp "" _ (MSG mId _ msg) <- tGet rh
+      Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
+      Resp "" _ (MSG mId _ _ msg) <- tGet rh
       (dec mId msg, Right "hello") #== "delivered from queue"
 
-      runTimingTest sh badKey sId $ SEND "hello"
+      runTimingTest sh badKey sId $ _SEND "hello"
       where
         generateKeys = \case
           32 -> C.generateSignatureKeyPair C.SEd25519
@@ -468,15 +612,15 @@ testMessageNotifications (ATransport t) =
       let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
       Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, NKEY nPub)
       Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)
-      Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, SEND "hello")
-      Resp "" _ (MSG mId1 _ msg1) <- tGet rh
+      Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND' "hello")
+      Resp "" _ (MSG mId1 _ _ msg1) <- tGet rh
       (dec mId1 msg1, Right "hello") #== "delivered from queue"
-      Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK)
+      Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
       Resp "" _ NMSG <- tGet nh1
       Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
       Resp "" _ END <- tGet nh1
-      Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, SEND "hello again")
-      Resp "" _ (MSG mId2 _ msg2) <- tGet rh
+      Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
+      Resp "" _ (MSG mId2 _ _ msg2) <- tGet rh
       (dec mId2 msg2, Right "hello again") #== "delivered from queue again"
       Resp "" _ NMSG <- tGet nh2
       1000 `timeout` tGet @BrokerMsg nh1 >>= \case
@@ -492,11 +636,11 @@ testMsgExpireOnSend t =
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
         let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should expire)")
+        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
         threadDelay 2500000
-        Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, SEND "hello (should NOT expire)")
+        Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)")
         testSMPClient @c $ \rh -> do
-          Resp "3" _ (MSG mId _ msg) <- signSendRecv rh rKey ("3", rId, SUB)
+          Resp "3" _ (MSG mId _ _ msg) <- signSendRecv rh rKey ("3", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
           1000 `timeout` tGet @BrokerMsg rh >>= \case
             Nothing -> return ()
@@ -510,7 +654,7 @@ testMsgExpireOnInterval t =
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should expire)")
+        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
         threadDelay 2500000
         testSMPClient @c $ \rh -> do
           Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, SUB)
@@ -527,10 +671,10 @@ testMsgNOTExpireOnInterval t =
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
         let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
-        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, SEND "hello (should NOT expire)")
+        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should NOT expire)")
         threadDelay 2500000
         testSMPClient @c $ \rh -> do
-          Resp "2" _ (MSG mId _ msg) <- signSendRecv rh rKey ("2", rId, SUB)
+          Resp "2" _ (MSG mId _ _ msg) <- signSendRecv rh rKey ("2", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
           1000 `timeout` tGet @BrokerMsg rh >>= \case
             Nothing -> return ()
@@ -560,13 +704,17 @@ syntaxTests (ATransport t) = do
     it "no signature" $ ("", "abcd", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "abcd", "12345678", ERR $ CMD NO_AUTH)
     it "no queue ID" $ (sampleSig, "bcda", "", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
   noParamsSyntaxTest "SUB" SUB_
-  noParamsSyntaxTest "ACK" ACK_
   noParamsSyntaxTest "OFF" OFF_
   noParamsSyntaxTest "DEL" DEL_
   describe "SEND" $ do
-    it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
+    it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
     it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
-    it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
+    it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
+  describe "ACK" $ do
+    it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
+    it "no parameters" $ (sampleSig, "abcd", "12345678", ACK_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
+    it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
+    it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
   describe "PING" $ do
     it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)
   describe "broker response not allowed" $ do

tests/Test.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE TypeApplications #-}
 
 import AgentTests (agentTests)
-import AgentTests.NotificationTests (notificationTests)
 import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.VersionRangeTests
@@ -25,8 +24,6 @@ main = do
       describe "Version range" versionRangeTests
     describe "SMP server via TLS" $ serverTests (transport @TLS)
     describe "SMP server via WebSockets" $ serverTests (transport @WS)
-    describe "Notifications server" $ do
-      ntfServerTests (transport @TLS)
-      notificationTests (transport @TLS)
+    describe "Notifications server" $ ntfServerTests (transport @TLS)
     describe "SMP client agent" $ agentTests (transport @TLS)
   removeDirectoryRecursive "tests/tmp"