3.0.1

* update stats logging and make it opt-in

* hSetBuffering

* update var name

CHANGELOG.md

@@ -1,3 +1,30 @@
+# 3.0.0
+
+SMP server:
+
+- restore undeliverd messages when the server is restarted.
+- SMP protocol v3 to support push notification:
+  - updated SEND and MSG to add message flags (for notification flag that contros whether the notification is sent and for any future extensions) and to move message meta-data sent to the recipient into the encrypted envelope.
+  - update NKEY and NID to add e2e encryption keys (for the notification meta-data encryption between SMP server and the client), and update NMSG to include this meta-data.
+  - update ACK command to include message ID (to avoid acknowledging unprocessed message).
+  - add NDEL commands to remove notification subscription credentials from SMP queue.
+  - add GET command to receive messages without subscription - to be used in iOS notification service extension to receive messages without terminating app subscriptions.
+
+SMP agent:
+
+- new protocol for duplex connection handshake reducing traffic and connection time.
+- support for SMP notifications server and managing device token.
+- remove redundant FQDN validation from TLS handshake to prepare for access via Tor.
+- support for fully stopping agent and for termporary suspending agent operations.
+- improve management of duplicate message delivery.
+
+SMP notifications server v1.0:
+
+- SMP notifications protocol with version negotiation during handshake.
+- device token registration and verification (via background notification).
+- SMP notification subscriptions and push notifications via APNS.
+- restoring notification subscriptions when the server is restarted.
+
 # 2.3.0
 
 SMP server:

apps/ntf-server/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Main where
@@ -41,7 +42,7 @@ ntfServerCLIConfig =
           fingerprintFile = combine cfgPath "fingerprint",
           defaultServerPort = "443",
           executableName = "ntf-server",
-          serverVersion = "SMP notifications server v0.1.0",
+          serverVersion = "SMP notifications server v1.0.1",
           mkIniFile = \enableStoreLog defaultServerPort ->
             "[STORE_LOG]\n\
             \# The server uses STM memory for persistence,\n\
@@ -50,13 +51,13 @@ ntfServerCLIConfig =
             \# 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")
+              <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
               <> "[TRANSPORT]\n\
                  \port: "
               <> defaultServerPort
               <> "\n\
                  \websockets: off\n",
-          mkServerConfig = \_storeLogFile transports _ ->
+          mkServerConfig = \storeLogFile transports _ ->
             NtfServerConfig
               { transports,
                 subIdBytes = 24,
@@ -67,6 +68,8 @@ ntfServerCLIConfig =
                 smpAgentCfg = defaultSMPClientAgentConfig,
                 apnsConfig = defaultAPNSPushClientConfig,
                 inactiveClientExpiration = Nothing,
+                storeLogFile,
+                resubscribeDelay = 50000, -- 50ms
                 caCertificateFile = caCrtFile,
                 privateKeyFile = serverKeyFile,
                 certificateFile = serverCrtFile

apps/smp-server/Main.hs

@@ -59,10 +59,11 @@ smpServerCLIConfig =
             \# This option enables saving memory to append only log,\n\
             \# and restoring it when the server is started.\n\
             \# Log is compacted on start (deleted objects are removed).\n"
-              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n")
-              <> "# The messages are optionally saved and restored when the server restarts,\n\
-                 \# they are deleted after restarting.\n"
-              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+              <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n")
+              <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
+                 \# they are preserved in the .bak file until the next restart.\n"
+              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n")
+              <> ("log_stats: off\n\n")
               <> "[TRANSPORT]\n"
               <> ("port: " <> defaultServerPort <> "\n")
               <> "websockets: off\n\n"
@@ -72,37 +73,38 @@ smpServerCLIConfig =
               <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
               <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
           mkServerConfig = \storeLogFile transports ini ->
-            ServerConfig
-              { transports,
-                tbqSize = 16,
-                serverTbqSize = 64,
-                msgQueueQuota = 128,
-                queueIdBytes = 24,
-                msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
-                caCertificateFile = caCrtFile,
-                privateKeyFile = serverKeyFile,
-                certificateFile = serverCrtFile,
-                storeLogFile,
-                storeMsgsFile =
-                  let messagesPath = combine logPath "smp-server-messages.log"
-                   in case lookupValue "STORE_LOG" "restore_messages" ini of
-                        Right "on" -> Just messagesPath
-                        Right _ -> Nothing
-                        -- if the setting is not set, it is enabled when store log is enabled
-                        _ -> storeLogFile $> messagesPath,
-                allowNewQueues = True,
-                messageExpiration = Just defaultMessageExpiration,
-                inactiveClientExpiration =
-                  if lookupValue "INACTIVE_CLIENTS" "disconnect" ini == Right "on"
-                    then
-                      Just
-                        ExpirationConfig
+            let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
+                logStats = settingIsOn "STORE_LOG" "log_stats"
+             in ServerConfig
+                  { transports,
+                    tbqSize = 16,
+                    serverTbqSize = 64,
+                    msgQueueQuota = 128,
+                    queueIdBytes = 24,
+                    msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
+                    caCertificateFile = caCrtFile,
+                    privateKeyFile = serverKeyFile,
+                    certificateFile = serverCrtFile,
+                    storeLogFile,
+                    storeMsgsFile =
+                      let messagesPath = combine logPath "smp-server-messages.log"
+                       in case lookupValue "STORE_LOG" "restore_messages" ini of
+                            Right "on" -> Just messagesPath
+                            Right _ -> Nothing
+                            -- if the setting is not set, it is enabled when store log is enabled
+                            _ -> storeLogFile $> messagesPath,
+                    allowNewQueues = True,
+                    messageExpiration = Just defaultMessageExpiration,
+                    inactiveClientExpiration =
+                      settingIsOn "INACTIVE_CLIENTS" "disconnect"
+                        $> ExpirationConfig
                           { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
                             checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                          }
-                    else Nothing,
-                logStatsInterval = Just 86400, -- seconds
-                logStatsStartTime = 0, -- seconds from 00:00 UTC
-                smpServerVRange = supportedSMPServerVRange
-              }
+                          },
+                    logStatsInterval = logStats $> 86400, -- seconds
+                    logStatsStartTime = 0, -- seconds from 00:00 UTC
+                    serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
+                    serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
+                    smpServerVRange = supportedSMPServerVRange
+                  }
         }

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 2.3.1
+version: 3.0.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -28,7 +28,7 @@ dependencies:
   - asn1-types == 0.3.*
   - async == 2.2.*
   - attoparsec == 0.14.*
-  - base >= 4.7 && < 5
+  - base >= 4.14 && < 5
   - base64-bytestring >= 1.0 && < 1.3
   - bytestring == 0.10.*
   - case-insensitive == 1.2.*
@@ -62,7 +62,7 @@ dependencies:
   - time == 1.9.*
   - time-compat == 1.9.*
   - time-manager == 0.0.*
-  - tls >= 1.6.0 && < 1.7
+  - tls >= 1.5.7 && < 1.6
   - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*

protocol/simplex-messaging.md

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

scripts/ntf-server-linode.sh

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

scripts/smp-server-linode.sh

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

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        2.3.1
+version:        3.0.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -49,6 +49,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
@@ -61,7 +62,9 @@ library
       Simplex.Messaging.Notifications.Server.Env
       Simplex.Messaging.Notifications.Server.Push.APNS
       Simplex.Messaging.Notifications.Server.Store
+      Simplex.Messaging.Notifications.Server.StoreLog
       Simplex.Messaging.Notifications.Transport
+      Simplex.Messaging.Notifications.Types
       Simplex.Messaging.Parsers
       Simplex.Messaging.Protocol
       Simplex.Messaging.Server
@@ -72,6 +75,7 @@ library
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.STM
+      Simplex.Messaging.Server.Stats
       Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
@@ -97,7 +101,7 @@ library
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.7 && <5
+    , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -130,7 +134,7 @@ library
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -157,7 +161,7 @@ executable ntf-server
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.7 && <5
+    , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -191,7 +195,7 @@ executable ntf-server
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -218,7 +222,7 @@ executable smp-agent
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.7 && <5
+    , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -252,7 +256,7 @@ executable smp-agent
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -279,7 +283,7 @@ executable smp-server
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.7 && <5
+    , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -313,7 +317,7 @@ executable smp-server
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -357,7 +361,7 @@ test-suite smp-server-test
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.7 && <5
+    , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
     , case-insensitive ==1.2.*
@@ -394,7 +398,7 @@ test-suite smp-server-test
     , time-compat ==1.9.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*

src/Simplex/Messaging/Agent.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      : Simplex.Messaging.Agent
@@ -55,15 +56,18 @@ module Simplex.Messaging.Agent
     setNtfServers,
     registerNtfToken,
     verifyNtfToken,
-    enableNtfCron,
     checkNtfToken,
     deleteNtfToken,
-    setAgentPhase,
+    getNtfToken,
+    getNtfTokenData,
+    deleteNtfSub,
+    activateAgent,
+    suspendAgent,
     logConnection,
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
+import Control.Concurrent.STM (flushTBQueue, stateTVar)
 import Control.Logger.Simple (logInfo, showText)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
@@ -80,29 +84,32 @@ import Data.Maybe (isJust)
 import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
-import Data.Word (Word16)
+import qualified Database.SQLite.Simple as DB
+-- import GHC.Conc (unsafeIOToSTM)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.NtfSubSupervisor
 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.Agent.Store.SQLite
 import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Client
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId)
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
+import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags)
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta)
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM, whenM, ($>>=))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, liftE, liftError, tryError, unlessM, whenM, ($>>=))
 import Simplex.Messaging.Version
 import System.Random (randomR)
 import UnliftIO.Async (async, race_)
-import UnliftIO.Concurrent (forkFinally)
+import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -152,12 +159,12 @@ subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 subscribeConnection c = withAgentEnv c . subscribeConnection' c
 
 -- | Get connection message (GET command)
-getConnectionMessage :: AgentErrorMonad m => AgentClient -> ConnId -> m (Maybe (SMP.MsgId, MsgFlags))
+getConnectionMessage :: AgentErrorMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
 getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
 
 -- | Get connection message for received notification
-getNotificationMessage :: AgentErrorMonad m => AgentClient -> ByteString -> m (Maybe (SMP.MsgId, MsgFlags))
-getNotificationMessage c = withAgentEnv c . getNotificationMessage' c
+getNotificationMessage :: AgentErrorMonad m => AgentClient -> C.CbNonce -> ByteString -> m (NotificationInfo, [SMPMsgMeta])
+getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
 
 resubscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
@@ -185,25 +192,36 @@ setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
 setNtfServers c = withAgentEnv c . setNtfServers' c
 
 -- | Register device notifications token
-registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-registerNtfToken c = withAgentEnv c . registerNtfToken' c
+registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
+registerNtfToken c = withAgentEnv c .: registerNtfToken' c
 
 -- | Verify device notifications token
-verifyNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
+verifyNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> m ()
 verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c
 
--- | Enable/disable periodic notifications
-enableNtfCron :: AgentErrorMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
-enableNtfCron c = withAgentEnv c .: enableNtfCron' c
-
 checkNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
 checkNtfToken c = withAgentEnv c . checkNtfToken' c
 
 deleteNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m ()
 deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 
-setAgentPhase :: AgentErrorMonad m => AgentClient -> AgentPhase -> m ()
-setAgentPhase c = withAgentEnv c . setAgentPhase' c
+getNtfToken :: AgentErrorMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode)
+getNtfToken c = withAgentEnv c $ getNtfToken' c
+
+getNtfTokenData :: AgentErrorMonad m => AgentClient -> m NtfToken
+getNtfTokenData c = withAgentEnv c $ getNtfTokenData' c
+
+-- | Delete notification subscription for connection
+deleteNtfSub :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
+deleteNtfSub c = withAgentEnv c . deleteNtfSub' c
+
+-- | Activate operations
+activateAgent :: AgentErrorMonad m => AgentClient -> m ()
+activateAgent c = withAgentEnv c $ activateAgent' c
+
+-- | Suspend operations with max delay to deliver pending messages
+suspendAgent :: AgentErrorMonad m => AgentClient -> Int -> m ()
+suspendAgent c = withAgentEnv c . suspendAgent' c
 
 withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
 withAgentEnv c = (`runReaderT` agentEnv c)
@@ -253,7 +271,7 @@ newConn c connId cMode = do
   g <- asks idsDrg
   agentVersion <- asks $ smpAgentVersion . config
   let cData = ConnData {connId, connAgentVersion = agentVersion, duplexHandshake = Nothing} -- connection mode is determined by the accepting agent
-  connId' <- withStore c $ \st -> createRcvConn st g cData rq cMode
+  connId' <- withStore c $ \db -> createRcvConn db g cData rq cMode
   addSubscription c rq connId'
   ns <- asks ntfSupervisor
   atomically $ sendNtfSubCommand ns (connId', NSCCreate)
@@ -263,7 +281,7 @@ newConn c connId cMode = do
     SCMContact -> pure (connId', CRContactUri crData)
     SCMInvitation -> do
       (pk1, pk2, e2eRcvParams) <- liftIO $ CR.generateE2EParams CR.e2eEncryptVersion
-      withStore c $ \st -> createRatchetX3dhKeys st connId' pk1 pk2
+      withStore' c $ \db -> createRatchetX3dhKeys db connId' pk1 pk2
       pure (connId', CRInvitationUri crData $ toVersionRangeT e2eRcvParams CR.e2eEncryptVRange)
 
 joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequestUri c -> ConnInfo -> m ConnId
@@ -274,7 +292,6 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
          agentVRange `compatibleVersion` aVRange
        ) of
     (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do
-      -- TODO in agent v2 - use found compatible version rather than current
       (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
       (_, rcDHRs) <- liftIO C.generateKeyPair'
       let rc = CR.initSndRatchet rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
@@ -282,9 +299,9 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
       g <- asks idsDrg
       let duplexHS = connAgentVersion /= 1
           cData = ConnData {connId, connAgentVersion, duplexHandshake = Just duplexHS}
-      connId' <- withStore c $ \st -> do
-        connId' <- createSndConn st g cData sq
-        createRatchet st connId' rc
+      connId' <- withStore c $ \db -> runExceptT $ do
+        connId' <- ExceptT $ createSndConn db g cData sq
+        liftIO $ createRatchet db connId' rc
         pure connId'
       let cData' = (cData :: ConnData) {connId = connId'}
       tryError (confirmQueue aVersion c connId' sq cInfo $ Just e2eSndParams) >>= \case
@@ -293,7 +310,7 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
           pure connId'
         Left e -> do
           -- TODO recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
-          withStore c (`deleteConn` connId')
+          withStore' c (`deleteConn` connId')
           throwError e
     _ -> throwError $ AGENT A_VERSION
 joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo = do
@@ -301,10 +318,9 @@ joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInf
   case ( qUri `compatibleVersion` SMP.smpClientVRange,
          agentVRange `compatibleVersion` aVRange
        ) of
-    (Just qInfo, Just _) -> do
-      -- TODO in agent v2 - use found compatible version rather than current
+    (Just qInfo, Just vrsn) -> do
       (connId', cReq) <- newConn c connId SCMInvitation
-      sendInvitation c qInfo cReq cInfo
+      sendInvitation c qInfo vrsn cReq cInfo
       pure connId'
     _ -> throwError $ AGENT A_VERSION
 
@@ -315,18 +331,20 @@ createReplyQueue c connId = do
   -- TODO reply queue version should be the same as send queue, ignoring it in v1
   let qInfo = toVersionT qUri SMP.smpClientVersion
   addSubscription c rq connId
-  withStore c $ \st -> upgradeSndConnToDuplex st connId rq
+  withStore c $ \db -> upgradeSndConnToDuplex db connId rq
   ns <- asks ntfSupervisor
   atomically $ sendNtfSubCommand ns (connId, NSCCreate)
   pure qInfo
 
 -- | Approve confirmation (LET command) in Reader monad
 allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
-allowConnection' c connId confId ownConnInfo = do
+allowConnection' c connId confId ownConnInfo =
   withStore c (`getConn` connId) >>= \case
     SomeConn _ (RcvConnection cData rq) -> do
-      AcceptedConfirmation {senderConf, ratchetState} <- withStore c $ \st -> acceptConfirmation st confId ownConnInfo
-      withStore c $ \st -> createRatchet st connId ratchetState
+      AcceptedConfirmation {senderConf} <- withStore c $ \db -> runExceptT $ do
+        conf <- ExceptT $ acceptConfirmation db confId ownConnInfo
+        liftIO $ createRatchet db connId $ ratchetState (conf :: AcceptedConfirmation)
+        pure conf
       processConfirmation c rq senderConf
       mapM_ (connectReplyQueues c cData ownConnInfo) (L.nonEmpty $ smpReplyQueues senderConf)
     _ -> throwError $ CMD PROHIBITED
@@ -337,21 +355,21 @@ acceptContact' c connId invId ownConnInfo = do
   Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ ContactConnection {} -> do
-      withStore c $ \st -> acceptInvitation st invId ownConnInfo
+      withStore' c $ \db -> acceptInvitation db invId ownConnInfo
       joinConn c connId connReq ownConnInfo
     _ -> throwError $ CMD PROHIBITED
 
 -- | Reject contact (RJCT command) in Reader monad
 rejectContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> m ()
 rejectContact' c contactConnId invId =
-  withStore c $ \st -> deleteInvitation st contactConnId invId
+  withStore c $ \db -> deleteInvitation db contactConnId invId
 
 processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SMPConfirmation -> m ()
 processConfirmation c rq@RcvQueue {e2ePrivKey} SMPConfirmation {senderKey, e2ePubKey} = do
   let dhSecret = C.dh' e2ePubKey e2ePrivKey
-  withStore c $ \st -> setRcvQueueConfirmedE2E st rq dhSecret
+  withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret
   secureQueue c rq senderKey
-  withStore c $ \st -> setRcvQueueStatus st rq Secured
+  withStore' c $ \db -> setRcvQueueStatus db rq Secured
 
 -- | Subscribe to receive connection messages (SUB command) in Reader monad
 subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
@@ -381,17 +399,41 @@ resubscribeConnection' c connId =
     (atomically $ hasActiveSubscription c connId)
     (subscribeConnection' c connId)
 
-getConnectionMessage' :: AgentMonad m => AgentClient -> ConnId -> m (Maybe (SMP.MsgId, MsgFlags))
+getConnectionMessage' :: AgentMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
 getConnectionMessage' c connId = do
   whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED
   withStore c (`getConn` connId) >>= \case
-    SomeConn _ (DuplexConnection _ rq _) -> getQueueMessage c rq connId
-    SomeConn _ (RcvConnection _ rq) -> getQueueMessage c rq connId
-    SomeConn _ (ContactConnection {}) -> throwError $ CMD PROHIBITED
-    SomeConn _ (SndConnection {}) -> throwError $ CONN SIMPLEX
+    SomeConn _ (DuplexConnection _ rq _) -> getQueueMessage c rq
+    SomeConn _ (RcvConnection _ rq) -> getQueueMessage c rq
+    SomeConn _ ContactConnection {} -> throwError $ CMD PROHIBITED
+    SomeConn _ SndConnection {} -> throwError $ CONN SIMPLEX
 
-getNotificationMessage' :: AgentErrorMonad m => AgentClient -> ByteString -> m (Maybe (SMP.MsgId, MsgFlags))
-getNotificationMessage' _c _encMessageInfo = throwError $ CMD PROHIBITED
+getNotificationMessage' :: forall m. AgentMonad m => AgentClient -> C.CbNonce -> ByteString -> m (NotificationInfo, [SMPMsgMeta])
+getNotificationMessage' c nonce encNtfInfo = do
+  withStore' c getActiveNtfToken >>= \case
+    Just NtfToken {ntfDhSecret = Just dhSecret} -> do
+      ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
+      PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData)
+      (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
+      ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchError` \_ -> pure Nothing
+      maxMsgs <- asks $ ntfMaxMessages . config
+      (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId maxMsgs ntfMsgMeta []
+    _ -> throwError $ CMD PROHIBITED
+  where
+    getNtfMessages ntfConnId maxMs nMeta ms
+      | length ms < maxMs =
+        getConnectionMessage' c ntfConnId >>= \case
+          Just m@SMP.SMPMsgMeta {msgId, msgTs, msgFlags} -> case nMeta of
+            Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'}
+              | msgId == msgId' || msgTs > msgTs' -> pure $ reverse (m : ms)
+              | otherwise -> getMsg (m : ms)
+            _
+              | SMP.notification msgFlags -> pure $ reverse (m : ms)
+              | otherwise -> getMsg (m : ms)
+          _ -> pure $ reverse ms
+      | otherwise = pure $ reverse ms
+      where
+        getMsg = getNtfMessages ntfConnId maxMs nMeta
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
@@ -412,18 +454,18 @@ enqueueMessage c cData@ConnData {connId, connAgentVersion} sq msgFlags aMessage
   pure $ unId msgId
   where
     storeSentMsg :: m InternalId
-    storeSentMsg = withStore c $ \st -> do
+    storeSentMsg = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- updateSndIds st connId
+      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
           agentMsg = AgentMessage privHeader aMessage
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr
-      encAgentMessage <- agentRatchetEncrypt st connId agentMsgStr e2eEncUserMsgLength
+      encAgentMessage <- agentRatchetEncrypt db connId agentMsgStr e2eEncUserMsgLength
       let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = connAgentVersion, encAgentMessage}
           msgType = agentMessageType agentMsg
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
-      createSndMsg st connId msgData
+      liftIO $ createSndMsg db connId msgData
       pure internalId
 
 resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
@@ -433,7 +475,7 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
     async (runSmpQueueMsgDelivery c cData sq)
       >>= \a -> atomically (TM.insert qKey a $ smpQueueMsgDeliveries c)
   unlessM connQueued $
-    withStore c (`getPendingMsgs` connId)
+    withStore' c (`getPendingMsgs` connId)
       >>= queuePendingMsgs c connId sq
   where
     queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
@@ -441,6 +483,9 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
 
 queuePendingMsgs :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> [InternalId] -> m ()
 queuePendingMsgs c connId sq msgIds = atomically $ do
+  modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
+  -- s <- readTVar (msgDeliveryOp c)
+  -- unsafeIOToSTM $ putStrLn $ "msgDeliveryOp: " <> show (opsInProgress s)
   q <- getPendingMsgQ c connId sq
   mapM_ (writeTQueue q) msgIds
 
@@ -459,11 +504,13 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
   mq <- atomically $ getPendingMsgQ c connId sq
   ri <- asks $ reconnectInterval . config
   forever $ do
-    atomically $ endAgentOperation c AONetwork
+    atomically $ endAgentOperation c AOSndNetwork
     msgId <- atomically $ readTQueue mq
-    atomically $ beginAgentOperation c AONetwork
+    atomically $ do
+      beginAgentOperation c AOSndNetwork
+      endAgentOperation c AOMsgDelivery
     let mId = unId msgId
-    withStore c (\st -> E.try $ getPendingMsgData st connId msgId) >>= \case
+    E.try (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
       Left (e :: E.SomeException) ->
         notify $ MERR mId (INTERNAL $ show e)
       Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, internalTs}) ->
@@ -507,16 +554,17 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
             Right () -> do
               case msgType of
                 AM_CONN_INFO -> do
-                  withStore c $ \st -> setSndQueueStatus st sq Confirmed
-                  when (isJust rq_) $ withStore c (`removeConfirmations` connId)
+                  withStore' c $ \db -> do
+                    setSndQueueStatus db sq Confirmed
+                    when (isJust rq_) $ removeConfirmations db connId
                   -- TODO possibly notification flag should be ON for one of the parties, to result in contact connected notification
                   unless (duplexHandshake == Just True) . void $ enqueueMessage c cData sq SMP.noMsgFlags HELLO
                 AM_HELLO_ -> do
-                  withStore c $ \st -> setSndQueueStatus st sq Active
+                  withStore' c $ \db -> setSndQueueStatus db sq Active
                   case rq_ of
                     -- party initiating connection (in v1)
                     Just RcvQueue {status} ->
-                      -- TODO it is unclear why subscribeQueue was needed here,
+                      -- it is unclear why subscribeQueue was needed here,
                       -- message delivery can only be enabled for queues that were created in the current session or subscribed
                       -- subscribeQueue c rq connId
                       --
@@ -537,16 +585,16 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
               delMsg msgId
   where
     delMsg :: InternalId -> m ()
-    delMsg msgId = withStore c $ \st -> deleteMsg st connId msgId
+    delMsg msgId = withStore' c $ \db -> deleteMsg db connId msgId
     notify :: ACommand 'Agent -> m ()
     notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
     notifyDel :: InternalId -> ACommand 'Agent -> m ()
     notifyDel msgId cmd = notify cmd >> delMsg msgId
     connError msgId = notifyDel msgId . ERR . CONN
     retrySending loop = do
-      atomically $ do
-        endAgentOperation c AONetwork
-        beginAgentOperation c AONetwork
+      -- end... is in a separate atomically because if begin... blocks, SUSPENDED won't be sent
+      atomically $ endAgentOperation c AOSndNetwork
+      atomically $ beginAgentOperation c AOSndNetwork
       loop
 
 ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
@@ -560,11 +608,11 @@ ackMessage' c connId msgId = do
     ack :: RcvQueue -> m ()
     ack rq = do
       let mId = InternalId msgId
-      srvMsgId <- withStore c $ \st -> setMsgUserAck st connId mId
+      srvMsgId <- withStore c $ \db -> setMsgUserAck db connId mId
       sendAck c rq srvMsgId `catchError` \case
         SMP SMP.NO_MSG -> pure ()
         e -> throwError e
-      withStore c $ \st -> deleteMsg st connId mId
+      withStore' c $ \db -> deleteMsg db connId mId
 
 -- | Suspend SMP agent connection (OFF command) in Reader monad
 suspendConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
@@ -582,48 +630,65 @@ deleteConnection' c connId =
     SomeConn _ (DuplexConnection _ rq _) -> delete rq
     SomeConn _ (RcvConnection _ rq) -> delete rq
     SomeConn _ (ContactConnection _ rq) -> delete rq
-    SomeConn _ (SndConnection _ _) -> withStore c (`deleteConn` connId)
+    SomeConn _ (SndConnection _ _) -> withStore' c (`deleteConn` connId)
   where
     delete :: RcvQueue -> m ()
     delete rq = do
       deleteQueue c rq
+      atomically $ removeSubscription c connId
+      withStore' c (`deleteConn` connId)
       ns <- asks ntfSupervisor
-      atomically $ do
-        removeSubscription c connId
-        sendNtfSubCommand ns (connId, NSCDelete)
-      withStore c (`deleteConn` connId)
+      atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
 
 -- | Change servers to be used for creating new queues, in Reader monad
 setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
-setSMPServers' c servers = do
-  atomically $ writeTVar (smpServers c) servers
+setSMPServers' c = atomically . writeTVar (smpServers c)
 
-registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
-registerNtfToken' c deviceToken =
-  withStore c (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId, ntfTknStatus, ntfTknAction}, prevTokens) -> do
-      mapM_ (deleteToken_ c) prevTokens
-      ns <- asks ntfSupervisor
-      case (ntfTokenId, ntfTknAction) of
-        (Nothing, Just NTARegister) -> registerToken tkn $> NTRegistered
+registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
+registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
+      status <- case (ntfTokenId, ntfTknAction) of
+        (Nothing, Just NTARegister) -> do
+          when (savedDeviceToken /= suppliedDeviceToken) $ withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
+          registerToken tkn $> NTRegistered
         -- TODO minimal time before repeat registration
-        (Just _, Nothing) -> when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
-        (Just tknId, Just (NTAVerify code)) ->
-          t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
-        (Just tknId, Just (NTACron interval)) ->
-          t tkn (cronSuccess interval) $ agentNtfEnableCron c tknId tkn interval
-        (Just _tknId, Just NTACheck) -> do
-          if ntfTknStatus == NTActive
-            then initializeNtfSubQ c tkn
-            else atomically $ nsUpdateToken ns tkn
-          pure ntfTknStatus -- TODO
-          -- agentNtfCheckToken c tknId tkn >>= \case
+        (Just tknId, Nothing)
+          | savedDeviceToken == suppliedDeviceToken ->
+            when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
+          | otherwise -> replaceToken tknId $> NTRegistered
+        (Just tknId, Just (NTAVerify code))
+          | savedDeviceToken == suppliedDeviceToken ->
+            t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
+          | otherwise -> replaceToken tknId $> NTRegistered
+        (Just tknId, Just NTACheck)
+          | savedDeviceToken == suppliedDeviceToken -> do
+            ns <- asks ntfSupervisor
+            atomically $ nsUpdateToken ns tkn {ntfMode = suppliedNtfMode}
+            when (ntfTknStatus == NTActive) $ do
+              cron <- asks $ ntfCron . config
+              agentNtfEnableCron c tknId tkn cron
+              when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
+              when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ smpDeleteNtfSubs c
+            pure ntfTknStatus -- TODO
+            -- agentNtfCheckToken c tknId tkn >>= \case
+          | otherwise -> replaceToken tknId $> NTRegistered
         (Just tknId, Just NTADelete) -> do
           agentNtfDeleteToken c tknId tkn
-          withStore c $ \st -> removeNtfToken st tkn
+          withStore' c (`removeNtfToken` tkn)
+          ns <- asks ntfSupervisor
           atomically $ nsRemoveNtfToken ns
           pure NTExpired
         _ -> pure ntfTknStatus
+      withStore' c $ \db -> updateNtfMode db tkn suppliedNtfMode
+      pure status
+      where
+        replaceToken :: NtfTokenId -> m ()
+        replaceToken tknId = do
+          agentNtfReplaceToken c tknId tkn suppliedDeviceToken
+          withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
+          ns <- asks ntfSupervisor
+          atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
     _ ->
       getNtfServer c >>= \case
         Just ntfServer ->
@@ -631,8 +696,8 @@ registerNtfToken' c deviceToken =
             C.SignAlg a -> do
               tknKeys <- liftIO $ C.generateSignatureKeyPair a
               dhKeys <- liftIO C.generateKeyPair'
-              let tkn = newNtfToken deviceToken ntfServer tknKeys dhKeys
-              withStore c $ \st -> createNtfToken st tkn
+              let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode
+              withStore' c (`createNtfToken` tkn)
               registerToken tkn
               pure NTRegistered
         _ -> throwError $ CMD PROHIBITED
@@ -642,102 +707,141 @@ registerNtfToken' c deviceToken =
     registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
       (tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
       let dhSecret = C.dh' srvPubDhKey privDhKey
-      withStore c $ \st -> updateNtfTokenRegistration st tkn tknId dhSecret
+      withStore' c $ \db -> updateNtfTokenRegistration db tkn tknId dhSecret
       ns <- asks ntfSupervisor
-      atomically $ nsUpdateToken ns tkn
+      atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
 
--- TODO decrypt verification code
-verifyNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
-verifyNtfToken' c deviceToken code nonce =
-  withStore c (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret}, _) -> do
+verifyNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> m ()
+verifyNtfToken' c deviceToken nonce code =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
+      when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
       code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
-      void . withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $ do
-        agentNtfVerifyToken c tknId tkn code'
+      toStatus <-
+        withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
+          agentNtfVerifyToken c tknId tkn code'
+      when (toStatus == NTActive) $ do
+        cron <- asks $ ntfCron . config
+        agentNtfEnableCron c tknId tkn cron
+        when (ntfMode == NMInstant) $ initializeNtfSubs c
     _ -> throwError $ CMD PROHIBITED
 
-enableNtfCron' :: AgentMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
-enableNtfCron' c deviceToken interval = do
-  when (interval < 20) . throwError $ CMD PROHIBITED
-  withStore c (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive}, _) ->
-      void . withToken c tkn (Just (NTActive, NTACron interval)) (cronSuccess interval) $
-        agentNtfEnableCron c tknId tkn interval
-    _ -> throwError $ CMD PROHIBITED
-
-cronSuccess :: Word16 -> (NtfTknStatus, Maybe NtfTknAction)
-cronSuccess interval
-  | interval == 0 = (NTActive, Just NTACheck)
-  | otherwise = (NTActive, Just $ NTACron interval)
-
 checkNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
 checkNtfToken' c deviceToken =
-  withStore c (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn@NtfToken {ntfTokenId = Just tknId}, _) -> agentNtfCheckToken c tknId tkn
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId} -> do
+      when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
+      agentNtfCheckToken c tknId tkn
     _ -> throwError $ CMD PROHIBITED
 
 deleteNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m ()
 deleteNtfToken' c deviceToken =
-  withStore c (`getDeviceNtfToken` deviceToken) >>= \case
-    (Just tkn, _) -> deleteToken_ c tkn
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
+      when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
+      deleteToken_ c tkn
+      smpDeleteNtfSubs c
     _ -> throwError $ CMD PROHIBITED
 
+getNtfToken' :: AgentMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode)
+getNtfToken' c =
+  withStore' c getSavedNtfToken >>= \case
+    Just NtfToken {deviceToken, ntfTknStatus, ntfMode} -> pure (deviceToken, ntfTknStatus, ntfMode)
+    _ -> throwError $ CMD PROHIBITED
+
+getNtfTokenData' :: AgentMonad m => AgentClient -> m NtfToken
+getNtfTokenData' c =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn -> pure tkn
+    _ -> throwError $ CMD PROHIBITED
+
+-- | Delete notification subscription for connection, in Reader monad
+deleteNtfSub' :: AgentMonad m => AgentClient -> ConnId -> m ()
+deleteNtfSub' _c connId = do
+  ns <- asks ntfSupervisor
+  atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
+
 deleteToken_ :: AgentMonad m => AgentClient -> NtfToken -> m ()
 deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
   ns <- asks ntfSupervisor
   forM_ ntfTokenId $ \tknId -> do
     let ntfTknAction = Just NTADelete
-    withStore c $ \st -> updateNtfToken st tkn ntfTknStatus ntfTknAction
+    withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
     atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
     agentNtfDeleteToken c tknId tkn `catchError` \case
       NTF AUTH -> pure ()
       e -> throwError e
-  withStore c $ \st -> removeNtfToken st tkn
+  withStore' c $ \db -> removeNtfToken db tkn
   atomically $ nsRemoveNtfToken ns
 
 withToken :: AgentMonad m => AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> m a -> m NtfTknStatus
-withToken c tkn@NtfToken {deviceToken} from_ (toStatus, toAction_) f = do
+withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
   ns <- asks ntfSupervisor
   forM_ from_ $ \(status, action) -> do
-    withStore c $ \st -> updateNtfToken st tkn status (Just action)
+    withStore' c $ \db -> updateNtfToken db tkn status (Just action)
     atomically $ nsUpdateToken ns tkn {ntfTknStatus = status, ntfTknAction = Just action}
   tryError f >>= \case
     Right _ -> do
-      withStore c $ \st -> updateNtfToken st tkn toStatus toAction_
+      withStore' c $ \db -> updateNtfToken db tkn toStatus toAction_
       let updatedToken = tkn {ntfTknStatus = toStatus, ntfTknAction = toAction_}
-      if toStatus == NTActive
-        then initializeNtfSubQ c updatedToken
-        else atomically $ nsUpdateToken ns updatedToken
+      atomically $ nsUpdateToken ns updatedToken
       pure toStatus
     Left e@(NTF AUTH) -> do
-      withStore c $ \st -> removeNtfToken st tkn
+      withStore' c $ \db -> removeNtfToken db tkn
       atomically $ nsRemoveNtfToken ns
-      void $ registerNtfToken' c deviceToken
+      void $ registerNtfToken' c deviceToken ntfMode
       throwError e
     Left e -> throwError e
 
-initializeNtfSubQ :: AgentMonad m => AgentClient -> NtfToken -> m ()
-initializeNtfSubQ c tkn = do
+initializeNtfSubs :: AgentMonad m => AgentClient -> m ()
+initializeNtfSubs c = do
   ns <- asks ntfSupervisor
-  connIds <- atomically $ do
-    nsUpdateToken ns tkn
-    getSubscriptions c
+  connIds <- atomically $ getSubscriptions c
   forM_ connIds $ \connId -> atomically $ sendNtfSubCommand ns (connId, NSCCreate)
 
+smpDeleteNtfSubs :: AgentMonad m => AgentClient -> m ()
+smpDeleteNtfSubs c = do
+  ns <- asks ntfSupervisor
+  void . atomically . flushTBQueue $ ntfSubQ ns
+  connIds <- atomically $ getSubscriptions c
+  forM_ connIds $ \connId -> atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCSmpDelete)
+
 -- TODO
 -- There should probably be another function to cancel all subscriptions that would flush the queue first,
--- so that superwisor stops processing pending commands?
+-- so that supervisor stops processing pending commands?
 -- It is an optimization, but I am thinking how it would behave if a user were to flip on/off quickly several times.
 
 setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
 setNtfServers' c = atomically . writeTVar (ntfServers c)
 
-setAgentPhase' :: AgentMonad m => AgentClient -> AgentPhase -> m ()
-setAgentPhase' c p = do
-  aPhase <- asks agentPhase
-  atomically $ do
-    writeTVar aPhase (p, False)
-    notifyAgentPhaseChanged c
+activateAgent' :: AgentMonad m => AgentClient -> m ()
+activateAgent' c = do
+  atomically $ writeTVar (agentState c) ASActive
+  mapM_ activate $ reverse agentOperations
+  where
+    activate opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = False}
+
+suspendAgent' :: AgentMonad m => AgentClient -> Int -> m ()
+suspendAgent' c 0 = do
+  atomically $ writeTVar (agentState c) ASSuspended
+  mapM_ suspend agentOperations
+  where
+    suspend opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = True}
+suspendAgent' c@AgentClient {agentState = as} maxDelay = do
+  state <-
+    atomically $ do
+      writeTVar as ASSuspending
+      suspendOperation c AONtfNetwork $ pure ()
+      suspendOperation c AORcvNetwork $
+        suspendOperation c AOMsgDelivery $
+          suspendSendingAndDatabase c
+      readTVar as
+  when (state == ASSuspending) . void . forkIO $ do
+    threadDelay maxDelay
+    -- liftIO $ putStrLn "suspendAgent after timeout"
+    atomically . whenSuspending c $ do
+      -- unsafeIOToSTM $ putStrLn $ "in timeout: suspendSendingAndDatabase"
+      suspendSendingAndDatabase c
 
 getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
 getSMPServer c = do
@@ -751,27 +855,25 @@ getSMPServer c = do
 
 subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
 subscriber c@AgentClient {msgQ} = forever $ do
-  atomically $ endAgentOperation c AONetwork
   t <- atomically $ readTBQueue msgQ
-  atomically $ beginAgentOperation c AONetwork
-  withAgentLock c (runExceptT $ processSMPTransmission c t) >>= \case
-    Left e -> liftIO $ print e
-    Right _ -> return ()
+  agentOperationBracket c AORcvNetwork $
+    withAgentLock c (runExceptT $ processSMPTransmission c t) >>= \case
+      Left e -> liftIO $ print e
+      Right _ -> return ()
 
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
-processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd) =
-  withStore c (\st -> getRcvConn st srv rId) >>= \case
+processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cmd) =
+  withStore c (\db -> getRcvConn db srv rId) >>= \case
     SomeConn _ conn@(DuplexConnection cData rq _) -> processSMP conn cData rq
     SomeConn _ conn@(RcvConnection cData rq) -> processSMP conn cData rq
     SomeConn _ conn@(ContactConnection cData rq) -> processSMP conn cData rq
     _ -> atomically $ writeTBQueue subQ ("", "", ERR $ CONN NOT_FOUND)
   where
     processSMP :: Connection c -> ConnData -> RcvQueue -> m ()
-    processSMP conn cData@ConnData {connId, duplexHandshake} rq@RcvQueue {rcvDhSecret, e2ePrivKey, e2eDhSecret, status} =
+    processSMP conn cData@ConnData {connId, duplexHandshake} rq@RcvQueue {e2ePrivKey, e2eDhSecret, status} =
       case cmd of
-        SMP.MSG srvMsgId srvTs msgFlags msgBody' -> handleNotifyAck $ do
-          -- TODO deduplicate with previously received
-          msgBody <- agentCbDecrypt rcvDhSecret (C.cbNonce srvMsgId) msgBody'
+        SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> handleNotifyAck $ do
+          SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} <- decryptSMPMessage v rq msg
           clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
             parseMessage msgBody
           unless (phVer `isCompatible` SMP.smpClientVRange) . throwError $ AGENT A_VERSION
@@ -789,19 +891,19 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
                 (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) ->
                   tryError agentClientMsg >>= \case
                     Right (Just (msgId, msgMeta, aMessage)) -> case aMessage of
-                      HELLO -> helloMsg >> ack >> withStore c (\st -> deleteMsg st connId msgId)
-                      REPLY cReq -> replyMsg cReq >> ack >> withStore c (\st -> deleteMsg st connId msgId)
+                      HELLO -> helloMsg >> ack >> withStore' c (\db -> deleteMsg db connId msgId)
+                      REPLY cReq -> replyMsg cReq >> ack >> withStore' c (\db -> deleteMsg db connId msgId)
                       -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
                       A_MSG body -> do
                         logServer "<--" c srv rId "MSG <MSG>"
                         notify $ MSG msgMeta msgFlags body
                     Right _ -> prohibited >> ack
                     Left e@(AGENT A_DUPLICATE) -> do
-                      withStore c (\st -> getLastMsg st connId srvMsgId) >>= \case
+                      withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
                         Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
                           | userAck -> do
                             ack
-                            withStore c $ \st -> deleteMsg st connId internalId
+                            withStore' c $ \db -> deleteMsg db connId internalId
                           | otherwise -> do
                             liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
                               AgentMessage _ (A_MSG body) -> do
@@ -812,20 +914,20 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
                     Left e -> throwError e
                   where
                     agentClientMsg :: m (Maybe (InternalId, MsgMeta, AMessage))
-                    agentClientMsg = withStore c $ \st -> do
-                      agentMsgBody <- agentRatchetDecrypt st connId encAgentMsg
+                    agentClientMsg = withStore c $ \db -> runExceptT $ do
+                      agentMsgBody <- agentRatchetDecrypt db connId encAgentMsg
                       liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
                         agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
                           let msgType = agentMessageType agentMsg
                               internalHash = C.sha256Hash agentMsgBody
                           internalTs <- liftIO getCurrentTime
-                          (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- updateRcvIds st connId
+                          (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- liftIO $ updateRcvIds db connId
                           let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash prevMsgHash
                               recipient = (unId internalId, internalTs)
                               broker = (srvMsgId, systemToUTCTime srvTs)
                               msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
                               rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash}
-                          createRcvMsg st connId rcvMsg
+                          liftIO $ createRcvMsg db connId rcvMsg
                           pure $ Just (internalId, msgMeta, aMessage)
                         _ -> pure Nothing
                 _ -> prohibited >> ack
@@ -886,7 +988,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
             New -> case (conn, e2eEncryption) of
               -- party initiating connection
               (RcvConnection {}, Just e2eSndParams) -> do
-                (pk1, rcDHRs) <- withStore c $ \st -> getRatchetX3dhKeys st connId
+                (pk1, rcDHRs) <- withStore c $ (`getRatchetX3dhKeys` connId)
                 let rc = CR.initRcvRatchet rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams
                 (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo
                 case (agentMsgBody_, skipped) of
@@ -901,14 +1003,14 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
                       processConf connInfo senderConf duplexHS = do
                         let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
                         g <- asks idsDrg
-                        confId <- withStore c $ \st -> do
-                          setHandshakeVersion st connId agentVersion duplexHS
-                          createConfirmation st g newConfirmation
+                        confId <- withStore c $ \db -> do
+                          setHandshakeVersion db connId agentVersion duplexHS
+                          createConfirmation db g newConfirmation
                         notify $ CONF confId connInfo
                   _ -> prohibited
               -- party accepting connection
               (DuplexConnection _ _ sq, Nothing) -> do
-                withStore c (\st -> agentRatchetDecrypt st connId encConnInfo) >>= parseMessage >>= \case
+                withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
                   AgentConnInfo connInfo -> do
                     notify $ INFO connInfo
                     processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []}
@@ -923,7 +1025,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
           case status of
             Active -> prohibited
             _ -> do
-              withStore c $ \st -> setRcvQueueStatus st rq Active
+              withStore' c $ \db -> setRcvQueueStatus db rq Active
               case conn of
                 DuplexConnection _ _ sq@SndQueue {status = sndStatus}
                   -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
@@ -956,7 +1058,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
             ContactConnection {} -> do
               g <- asks idsDrg
               let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
-              invId <- withStore c $ \st -> createInvitation st g newInv
+              invId <- withStore c $ \db -> createInvitation db g newInv
               notify $ REQ invId cInfo
             _ -> prohibited
 
@@ -976,7 +1078,7 @@ connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do
     Nothing -> throwError $ AGENT A_VERSION
     Just qInfo' -> do
       sq <- newSndQueue qInfo'
-      withStore c $ \st -> upgradeRcvConnToDuplex st connId sq
+      withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
       enqueueConfirmation c cData sq ownConnInfo Nothing
 
 confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
@@ -984,12 +1086,12 @@ confirmQueue (Compatible agentVersion) c connId sq connInfo e2eEncryption = do
   aMessage <- mkAgentMessage agentVersion
   msg <- mkConfirmation aMessage
   sendConfirmation c sq msg
-  withStore c $ \st -> setSndQueueStatus st sq Confirmed
+  withStore' c $ \db -> setSndQueueStatus db sq Confirmed
   where
     mkConfirmation :: AgentMessage -> m MsgBody
-    mkConfirmation aMessage = withStore c $ \st -> do
-      void $ updateSndIds st connId
-      encConnInfo <- agentRatchetEncrypt st connId (smpEncode aMessage) e2eEncConnInfoLength
+    mkConfirmation aMessage = withStore c $ \db -> runExceptT $ do
+      void . liftIO $ updateSndIds db connId
+      encConnInfo <- agentRatchetEncrypt db connId (smpEncode aMessage) e2eEncConnInfoLength
       pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}
     mkAgentMessage :: Version -> m AgentMessage
     mkAgentMessage 1 = pure $ AgentConnInfo connInfo
@@ -1004,34 +1106,34 @@ enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eE
   queuePendingMsgs c connId sq [msgId]
   where
     storeConfirmation :: m InternalId
-    storeConfirmation = withStore c $ \st -> do
+    storeConfirmation = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- updateSndIds st connId
+      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let agentMsg = AgentConnInfo connInfo
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr
-      encConnInfo <- agentRatchetEncrypt st connId agentMsgStr e2eEncConnInfoLength
+      encConnInfo <- agentRatchetEncrypt db connId agentMsgStr e2eEncConnInfoLength
       let msgBody = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption, encConnInfo}
           msgType = agentMessageType agentMsg
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
-      createSndMsg st connId msgData
+      liftIO $ createSndMsg db connId msgData
       pure internalId
 
 -- encoded AgentMessage -> encoded EncAgentMessage
-agentRatchetEncrypt :: AgentStoreMonad m => SQLiteStore -> ConnId -> ByteString -> Int -> m ByteString
-agentRatchetEncrypt st connId msg paddedLen = do
-  rc <- getRatchet st connId
-  (encMsg, rc') <- liftError (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg
-  updateRatchet st connId rc' CR.SMDNoChange
+agentRatchetEncrypt :: DB.Connection -> ConnId -> ByteString -> Int -> ExceptT StoreError IO ByteString
+agentRatchetEncrypt db connId msg paddedLen = do
+  rc <- ExceptT $ getRatchet db connId
+  (encMsg, rc') <- liftE (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg
+  liftIO $ updateRatchet db connId rc' CR.SMDNoChange
   pure encMsg
 
 -- encoded EncAgentMessage -> encoded AgentMessage
-agentRatchetDecrypt :: AgentStoreMonad m => SQLiteStore -> ConnId -> ByteString -> m ByteString
-agentRatchetDecrypt st connId encAgentMsg = do
-  rc <- getRatchet st connId
-  skipped <- getSkippedMsgKeys st connId
-  (agentMsgBody_, rc', skippedDiff) <- liftError (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
-  updateRatchet st connId rc' skippedDiff
+agentRatchetDecrypt :: DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt db connId encAgentMsg = do
+  rc <- ExceptT $ getRatchet db connId
+  skipped <- liftIO $ getSkippedMsgKeys db connId
+  (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
+  liftIO $ updateRatchet db connId rc' skippedDiff
   liftEither $ first (SEAgentError . cryptoError) agentMsgBody_
 
 newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> m SndQueue

src/Simplex/Messaging/Agent/Client.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Agent.Client
@@ -21,6 +22,7 @@ module Simplex.Messaging.Agent.Client
     newRcvQueue,
     subscribeQueue,
     getQueueMessage,
+    decryptSMPMessage,
     addSubscription,
     getSubscriptions,
     sendConfirmation,
@@ -28,14 +30,17 @@ module Simplex.Messaging.Agent.Client
     RetryInterval (..),
     secureQueue,
     enableQueueNotifications,
+    disableQueueNotifications,
     sendAgentMessage,
     agentNtfRegisterToken,
     agentNtfVerifyToken,
     agentNtfCheckToken,
+    agentNtfReplaceToken,
     agentNtfDeleteToken,
     agentNtfEnableCron,
     agentNtfCreateSubscription,
     agentNtfCheckSubscription,
+    agentNtfDeleteSubscription,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -46,10 +51,19 @@ module Simplex.Messaging.Agent.Client
     removeSubscription,
     hasActiveSubscription,
     agentDbPath,
+    AgentOperation (..),
+    AgentOpState (..),
+    AgentState (..),
+    agentOperations,
+    agentOperationBracket,
     beginAgentOperation,
     endAgentOperation,
-    notifyAgentPhaseChanged,
+    suspendSendingAndDatabase,
+    suspendOperation,
+    notifySuspended,
+    whenSuspending,
     withStore,
+    withStore',
   )
 where
 
@@ -71,19 +85,21 @@ import Data.Maybe (catMaybes)
 import Data.Set (Set)
 import Data.Text.Encoding
 import Data.Word (Word16)
-import Database.SQLite.Simple (SQLError)
+import qualified Database.SQLite.Simple as DB
 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.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
 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, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
+import Simplex.Messaging.Notifications.Types
+import Simplex.Messaging.Parsers (parse)
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, NtfServer, ProtoServer, ProtocolServer (..), QueueId, QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, SMPMsgMeta (..), SndPublicVerifyKey)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -115,7 +131,13 @@ 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 ()),
+    ntfNetworkOp :: TVar AgentOpState,
+    rcvNetworkOp :: TVar AgentOpState,
+    msgDeliveryOp :: TVar AgentOpState,
+    sndNetworkOp :: TVar AgentOpState,
+    databaseOp :: TVar AgentOpState,
+    agentState :: TVar AgentState,
+    getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()),
     reconnections :: TVar [Async ()],
     asyncClients :: TVar [Async ()],
     clientId :: Int,
@@ -123,6 +145,25 @@ data AgentClient = AgentClient
     lock :: TMVar ()
   }
 
+data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
+  deriving (Eq, Show)
+
+agentOpSel :: AgentOperation -> (AgentClient -> TVar AgentOpState)
+agentOpSel = \case
+  AONtfNetwork -> ntfNetworkOp
+  AORcvNetwork -> rcvNetworkOp
+  AOMsgDelivery -> msgDeliveryOp
+  AOSndNetwork -> sndNetworkOp
+  AODatabase -> databaseOp
+
+agentOperations :: [AgentClient -> TVar AgentOpState]
+agentOperations = [ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp]
+
+data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int}
+
+data AgentState = ASActive | ASSuspending | ASSuspended
+  deriving (Eq, Show)
+
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
 newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   let qSize = tbqSize $ config agentEnv
@@ -140,18 +181,24 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   connMsgsQueued <- TM.empty
   smpQueueMsgQueues <- TM.empty
   smpQueueMsgDeliveries <- TM.empty
+  ntfNetworkOp <- newTVar $ AgentOpState False 0
+  rcvNetworkOp <- newTVar $ AgentOpState False 0
+  msgDeliveryOp <- newTVar $ AgentOpState False 0
+  sndNetworkOp <- newTVar $ AgentOpState False 0
+  databaseOp <- newTVar $ AgentOpState False 0
+  agentState <- newTVar ASActive
   getMsgLocks <- TM.empty
   reconnections <- newTVar []
   asyncClients <- newTVar []
-  clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
+  clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
   lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
 
 agentDbPath :: AgentClient -> FilePath
 agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
 
 class ProtocolServerClient msg where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
+  getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg)
   clientProtocolError :: ErrorType -> AgentErrorType
 
 instance ProtocolServerClient BrokerMsg where
@@ -203,6 +250,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
       whenM (readTVarIO active) $ do
         let conns = M.keys cs
         unless (null conns) . notifySub "" $ DOWN srv conns
+        atomically $ mapM_ (releaseGetLock c) cs
         unliftIO u reconnectServer
 
     reconnectServer :: m ()
@@ -267,7 +315,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
       atomically $ TM.delete srv ntfClients
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-getClientVar :: forall a. ProtocolServer -> TMap ProtocolServer (TMVar a) -> STM (Either (TMVar a) (TMVar a))
+getClientVar :: forall a s. ProtocolServer s -> TMap (ProtocolServer s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
 getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
   where
     newClientVar :: STM (TMVar a)
@@ -289,8 +337,8 @@ newProtocolClient ::
   forall msg m.
   AgentMonad m =>
   AgentClient ->
-  ProtocolServer ->
-  TMap ProtocolServer (ClientVar msg) ->
+  ProtoServer msg ->
+  TMap (ProtoServer msg) (ClientVar msg) ->
   m (ProtocolClient msg) ->
   m () ->
   ClientVar msg ->
@@ -333,12 +381,13 @@ closeAgentClient c = liftIO $ do
   clear subscrConns
   clear connMsgsQueued
   clear smpQueueMsgQueues
+  clear getMsgLocks
   where
     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 :: Int -> TMap (ProtoServer msg) (ClientVar msg) -> IO ()
 closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
   where
     closeClient cVar =
@@ -355,7 +404,7 @@ withAgentLock AgentClient {lock} =
     (void . atomically $ takeTMVar lock)
     (atomically $ putTMVar lock ())
 
-withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> m a) -> m a
+withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> m a) -> m a
 withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
   where
     logServerError :: AgentErrorType -> m a
@@ -363,17 +412,17 @@ withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchErro
       logServer "<--" c srv "" $ bshow e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
 withLogClient_ c srv qId cmdStr action = do
   logServer "-->" c srv qId cmdStr
   res <- withClient_ c srv action
   logServer "<--" c srv qId "OK"
   return res
 
-withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
 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 :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
 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
@@ -383,7 +432,7 @@ protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> A
 protocolClientError protocolError_ = \case
   PCEProtocolError e -> protocolError_ e
   PCEResponseError e -> BROKER $ RESPONSE e
-  PCEUnexpectedResponse -> BROKER UNEXPECTED
+  PCEUnexpectedResponse _ -> BROKER UNEXPECTED
   PCEResponseTimeout -> BROKER TIMEOUT
   PCENetworkError -> BROKER NETWORK
   PCETransportError e -> BROKER $ TRANSPORT e
@@ -419,15 +468,13 @@ newRcvQueue_ a c srv = do
             e2eDhSecret = Nothing,
             sndId = Just sndId,
             status = New,
-            ntfPublicKey = Nothing,
-            ntfPrivateKey = Nothing,
-            notifierId = Nothing
+            clientNtfCreds = 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
+  whenM (atomically . TM.member (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
@@ -473,11 +520,11 @@ getSubscriptions AgentClient {subscrConns} = do
   m <- readTVar subscrConns
   pure $ M.keysSet m
 
-logServer :: MonadIO m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
+logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
   logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 
-showServer :: SMPServer -> ByteString
+showServer :: ProtocolServer s -> ByteString
 showServer ProtocolServer {host, port} =
   B.pack $ host <> if null port then "" else ':' : port
 
@@ -492,8 +539,8 @@ sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey,
     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 =
+sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (Compatible agentVersion) connReq connInfo =
   withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
     msg <- mkInvitation
     liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
@@ -501,42 +548,56 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) co
     mkInvitation :: m ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
     mkInvitation = do
-      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
+getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
+getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
+  atomically createTakeGetLock
+  (v, msg_) <- withLogClient c server rcvId "GET" $ \smp ->
+    (thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
+  mapM (decryptMeta v) msg_
   where
-    k = (connId, server, rcvId)
-    createTakeLock = do
-      l <- TM.lookup k getMsgLocks >>= maybe newLock pure
-      takeTMVar l
-      pure l
+    decryptMeta v msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage v rq msg
+    createTakeGetLock = TM.alterF takeLock (server, rcvId) $ getMsgLocks c
       where
-        newLock = do
-          l <- newTMVar ()
-          TM.insert k l getMsgLocks
-          pure l
+        takeLock l_ = do
+          l <- maybe (newTMVar ()) pure l_
+          takeTMVar l
+          pure $ Just l
+
+decryptSMPMessage :: AgentMonad m => Version -> RcvQueue -> SMP.RcvMessage -> m SMP.ClientRcvMsgBody
+decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.EncRcvMsgBody body}
+  | v == 1 || v == 2 = SMP.ClientRcvMsgBody msgTs msgFlags <$> decrypt body
+  | otherwise = liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
+  where
+    decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
 
 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
 
-enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> m NotifierId
-enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey =
+enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey)
+enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
   withLogClient c server rcvId "NKEY <nkey>" $ \smp ->
-    enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey
+    enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
+
+disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
+disableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} =
+  withLogClient c server rcvId "NDEL" $ \smp ->
+    disableSMPQueueNotifications smp rcvPrivateKey rcvId
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
-sendAck c RcvQueue {server, rcvId, rcvPrivateKey} msgId =
+sendAck c rq@RcvQueue {server, rcvId, rcvPrivateKey} msgId = do
   withLogClient c server rcvId "ACK" $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
+  atomically $ releaseGetLock c rq
+
+releaseGetLock :: AgentClient -> RcvQueue -> STM ()
+releaseGetLock c RcvQueue {server, rcvId} =
+  TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
 
 suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
@@ -567,6 +628,10 @@ agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m
 agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
   withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
 
+agentNtfReplaceToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> m ()
+agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
+  withLogClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
+
 agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
 agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
   withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
@@ -583,6 +648,10 @@ agentNtfCheckSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId ->
 agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withLogClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
 
+agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m ()
+agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
+  withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
+
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
@@ -624,40 +693,75 @@ cryptoError = \case
   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
+endAgentOperation c op = endOperation c op $ case op of
+  AONtfNetwork -> pure ()
+  AORcvNetwork ->
+    suspendOperation c AOMsgDelivery $
+      suspendSendingAndDatabase c
+  AOMsgDelivery ->
+    suspendSendingAndDatabase c
+  AOSndNetwork ->
+    suspendOperation c AODatabase $
+      notifySuspended c
+  AODatabase ->
+    notifySuspended c
+
+suspendSendingAndDatabase :: AgentClient -> STM ()
+suspendSendingAndDatabase c =
+  suspendOperation c AOSndNetwork $
+    suspendOperation c AODatabase $
+      notifySuspended c
+
+suspendOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
+suspendOperation c op endedAction = do
+  n <- stateTVar (agentOpSel op c) $ \s -> (opsInProgress s, s {opSuspended = True})
+  -- unsafeIOToSTM $ putStrLn $ "suspendOperation_ " <> show op <> " " <> show n
+  when (n == 0) $ whenSuspending c endedAction
+
+notifySuspended :: AgentClient -> STM ()
+notifySuspended c = do
+  -- unsafeIOToSTM $ putStrLn "notifySuspended"
+  writeTBQueue (subQ c) ("", "", SUSPENDED)
+  writeTVar (agentState c) ASSuspended
+
+endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
+endOperation c op endedAction = do
+  (suspended, n) <- stateTVar (agentOpSel op c) $ \s ->
+    let n = max 0 (opsInProgress s - 1)
+     in ((opSuspended s, n), s {opsInProgress = n})
+  -- unsafeIOToSTM $ putStrLn $ "endOperation: " <> show op <> " " <> show suspended <> " " <> show n
+  when (suspended && n == 0) $ whenSuspending c endedAction
+
+whenSuspending :: AgentClient -> STM () -> STM ()
+whenSuspending c = whenM ((== ASSuspending) <$> readTVar (agentState 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
+beginAgentOperation c op = do
+  let opVar = agentOpSel op c
+  s <- readTVar opVar
+  -- unsafeIOToSTM $ putStrLn $ "beginOperation? " <> show op <> " " <> show (opsInProgress s)
+  when (opSuspended s) retry
+  -- unsafeIOToSTM $ putStrLn $ "beginOperation! " <> show op <> " " <> show (opsInProgress s + 1)
+  writeTVar opVar $! s {opsInProgress = opsInProgress s + 1}
 
-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)
+agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> m a -> m a
+agentOperationBracket c op action =
+  E.bracket
+    (atomically $ beginAgentOperation c op)
+    (\_ -> atomically $ endAgentOperation c op)
+    (const action)
 
-withStore :: AgentMonad m => AgentClient -> (forall m'. AgentStoreMonad m' => SQLiteStore -> m' a) -> m a
+withStore' :: AgentMonad m => AgentClient -> (DB.Connection -> IO a) -> m a
+withStore' c action = withStore c $ fmap Right . action
+
+withStore :: AgentMonad m => AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
 withStore c action = do
   st <- asks store
-  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
+  liftEitherError storeError . agentOperationBracket c AODatabase $
+    withTransaction st action `E.catch` handleInternal
   where
-    -- TODO when parsing exception happens in store, the agent hangs;
-    -- changing SQLError to SomeException does not help
-    handleInternal :: (MonadError StoreError m') => SQLError -> m' a
-    handleInternal e = throwError . SEInternal $ bshow e
+    handleInternal :: E.SomeException -> IO (Either StoreError a)
+    handleInternal = pure . Left . SEInternal . bshow
     storeError :: StoreError -> AgentErrorType
     storeError = \case
       SEConnNotFound -> CONN NOT_FOUND

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
@@ -17,8 +16,6 @@ module Simplex.Messaging.Agent.Env.SQLite
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
-    AgentOperation (..),
-    disallowedOperations,
     newSMPAgentEnv,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
@@ -31,6 +28,7 @@ import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
+import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
@@ -40,7 +38,8 @@ 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, NtfToken)
+import Simplex.Messaging.Notifications.Types
+import Simplex.Messaging.Protocol (NtfServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
@@ -69,8 +68,11 @@ data AgentConfig = AgentConfig
     reconnectInterval :: RetryInterval,
     helloTimeout :: NominalDiffTime,
     resubscriptionConcurrency :: Int,
-    ntfWorkerThrottle :: Int,
+    ntfCron :: Word16,
+    ntfWorkerDelay :: Int,
+    ntfSMPWorkerDelay :: Int,
     ntfSubCheckInterval :: NominalDiffTime,
+    ntfMaxMessages :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
@@ -102,8 +104,11 @@ defaultAgentConfig =
       reconnectInterval = defaultReconnectInterval,
       helloTimeout = 2 * nominalDay,
       resubscriptionConcurrency = 16,
-      ntfWorkerThrottle = 1000000, -- microseconds
+      ntfCron = 20, -- minutes
+      ntfWorkerDelay = 100000, -- microseconds
+      ntfSMPWorkerDelay = 500000, -- microseconds
       ntfSubCheckInterval = nominalDay,
+      ntfMaxMessages = 4,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -119,30 +124,17 @@ data Env = Env
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
     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, yesToMigrations} = do
   idsDrg <- newTVarIO =<< drgNew
   store <- liftIO $ createSQLiteStore dbFile Migrations.app yesToMigrations
   clientCounter <- newTVarIO 0
   randomServer <- newTVarIO =<< liftIO newStdGen
-  agentPhase <- newTVarIO (APActive, True)
-  agentOperations <- atomically TM.empty
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
-  return Env {config, store, idsDrg, clientCounter, randomServer, agentPhase, agentOperations, ntfSupervisor}
+  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
 
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
@@ -151,7 +143,8 @@ data NtfSupervisor = NtfSupervisor
     ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
   }
 
-data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCNtfWorker NtfServer
+data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
+  deriving (Show)
 
 newNtfSubSupervisor :: Natural -> STM NtfSupervisor
 newNtfSubSupervisor qSize = do

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.NtfSubSupervisor
   ( runNtfSupervisor,
@@ -17,89 +18,130 @@ where
 
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
-import Control.Monad.Except (runExceptT)
+import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Data.Bifunctor (first)
 import Data.Fixed (Fixed (MkFixed), Pico)
 import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (ConnId)
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
 import qualified Simplex.Messaging.Agent.Protocol as AP
+import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
+import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (unlessM)
+import Simplex.Messaging.Util (tshow, 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
+runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runNtfSupervisor c = do
   ns <- asks ntfSupervisor
-  cmd <- atomically . readTBQueue $ ntfSubQ ns
-  runExceptT (processNtfSub c cmd) >>= \case
-    Left e -> liftIO $ print e
-    Right _ -> return ()
+  forever $ do
+    cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
+    handleError connId . agentOperationBracket c AONtfNetwork $
+      runExceptT (processNtfSub c cmd) >>= \case
+        Left e -> notifyErr connId e
+        Right _ -> return ()
+  where
+    handleError :: ConnId -> m () -> m ()
+    handleError connId = E.handle $ \(e :: E.SomeException) -> do
+      logError $ "runNtfSupervisor error " <> tshow e
+      notifyErr connId e
+    notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
 
 processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
 processNtfSub c (connId, cmd) = do
-  ntfServer_ <- getNtfServer c
+  logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
   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
+      (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
+        a <- liftIO $ getNtfSubscription db connId
+        q <- ExceptT $ getRcvQueue db connId
+        pure (a, q)
+      logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
+      case a of
+        Nothing -> do
+          withNtfServer c $ \ntfServer -> do
+            case clientNtfCreds of
+              Just ClientNtfCreds {notifierId} -> do
+                let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
+                ts <- liftIO getCurrentTime
+                withStore' c $ \db -> createNtfSubscription db newSub (NtfSubNTFAction NSACreate) ts
+                addNtfNTFWorker ntfServer
+              Nothing -> do
+                let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
+                ts <- liftIO getCurrentTime
+                withStore' c $ \db -> createNtfSubscription db newSub (NtfSubSMPAction NSASmpKey) ts
+                addNtfSMPWorker smpServer
+        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer}, action_)) -> do
+          case action_ of
+            -- action was set to NULL after worker internal error
+            Nothing -> resetSubscription
+            Just (action, _)
+              -- subscription was marked for deletion / is being deleted
+              | isDeleteNtfSubAction action -> do
+                if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
+                  then resetSubscription
+                  else withNtfServer c $ \ntfServer -> do
+                    ts <- liftIO getCurrentTime
+                    withStore' c $ \db ->
+                      supervisorUpdateNtfSubscription db sub {ntfServer} (NtfSubNTFAction NSACreate) ts
+                    addNtfNTFWorker ntfServer
+              | otherwise -> case action of
+                NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
+                NtfSubSMPAction _ -> addNtfSMPWorker smpServer
+          where
+            resetSubscription :: m ()
+            resetSubscription =
+              withNtfServer c $ \ntfServer -> do
+                ts <- liftIO getCurrentTime
+                withStore' c $ \db ->
+                  supervisorUpdateNtfSubscription db sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
+                addNtfSMPWorker smpServer
     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 ()
+      sub_ <- withStore' c $ \db -> do
+        ts <- liftIO getCurrentTime
+        supervisorUpdateNtfSubAction db connId (NtfSubNTFAction NSADelete) ts
+        getNtfSubscription db connId
+      logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
+      case sub_ of
+        (Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
+        _ -> pure () -- err "NSCDelete - no subscription"
+    NSCSmpDelete -> do
+      withStore' c (`getRcvQueue` connId) >>= \case
+        Right rq@RcvQueue {server = smpServer} -> do
+          logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
+          ts <- liftIO getCurrentTime
+          withStore' c $ \db -> supervisorUpdateNtfSubAction db connId (NtfSubSMPAction NSASmpDelete) ts
+          addNtfSMPWorker smpServer
+        _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
     NSCNtfWorker ntfServer ->
-      addNtfWorker ntfServer
+      addNtfNTFWorker ntfServer
+    NSCNtfSMPWorker smpServer ->
+      addNtfSMPWorker smpServer
   where
-    addNtfWorker = addWorker ntfWorkers runNtfWorker
+    addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
     addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
     addWorker ::
-      (NtfSupervisor -> TMap ProtocolServer (TMVar (), Async ())) ->
-      (AgentClient -> ProtocolServer -> TMVar () -> m ()) ->
-      ProtocolServer ->
+      (NtfSupervisor -> TMap (ProtocolServer s) (TMVar (), Async ())) ->
+      (AgentClient -> ProtocolServer s -> TMVar () -> m ()) ->
+      ProtocolServer s ->
       m ()
     addWorker wsSel runWorker srv = do
       ws <- asks $ wsSel . ntfSupervisor
@@ -111,95 +153,138 @@ processNtfSub c (connId, cmd) = do
         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
+withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
+withNtfServer c action = getNtfServer c >>= mapM_ action
+
+runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
+runNtfWorker c srv doWork = do
+  delay <- asks $ ntfWorkerDelay . config
+  forever $ do
+    void . atomically $ readTMVar doWork
+    agentOperationBracket c AONtfNetwork runNtfOperation
+    threadDelay delay
+  where
+    runNtfOperation :: m ()
+    runNtfOperation = do
+      nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
+      logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
       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
+        Just a@(NtfSubscription {connId}, _, _) -> do
+          ri <- asks $ reconnectInterval . config
+          withRetryInterval ri $ \loop ->
+            processAction a
+              `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
+    processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
+      ts <- liftIO getCurrentTime
+      unlessM (rescheduleAction doWork ts actionTs) $
+        case action of
+          NSACreate ->
+            getNtfToken >>= \case
+              Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
+                RcvQueue {clientNtfCreds} <- withStore c (`getRcvQueue` connId)
+                case clientNtfCreds of
+                  Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
+                    nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
+                    -- TODO smaller retry until Active, less frequently (daily?) once Active
+                    let actionTs' = addUTCTime 30 ts
+                    withStore' c $ \db ->
+                      updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
+                  _ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
+              _ -> workerInternalError c connId "NSACreate - no active token"
+          NSACheck ->
+            getNtfToken >>= \case
+              Just tkn ->
+                case ntfSubId of
+                  Just nSubId ->
+                    agentNtfCheckSubscription c nSubId tkn >>= \case
+                      NSAuth -> do
+                        getNtfServer c >>= \case
+                          Just ntfServer -> do
+                            withStore' c $ \db ->
+                              updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
+                            ns <- asks ntfSupervisor
+                            atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+                          _ -> workerInternalError c connId "NSACheck - failed to reset subscription, notification server not configured"
+                      status -> updateSubNextCheck ts status
+                  Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
+              _ -> workerInternalError c connId "NSACheck - no active token"
+          NSADelete -> case ntfSubId of
+            Just nSubId ->
+              (getNtfToken >>= \tkn -> forM_ tkn $ agentNtfDeleteSubscription c nSubId)
+                `E.finally` carryOnWithDeletion
+            Nothing -> carryOnWithDeletion
+            where
+              carryOnWithDeletion :: m ()
+              carryOnWithDeletion = do
+                withStore' c $ \db ->
+                  updateNtfSubscription db sub {ntfSubId = Nothing, ntfSubStatus = NASOff} (NtfSubSMPAction NSASmpDelete) ts
+                ns <- asks ntfSupervisor
+                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+      where
+        updateSubNextCheck ts toStatus = do
+          checkInterval <- asks $ ntfSubCheckInterval . config
+          let nextCheckTs = addUTCTime checkInterval ts
+          updateSub (NASCreated toStatus) (NtfSubNTFAction NSACheck) nextCheckTs
+        updateSub toStatus toAction actionTs' =
+          withStore' c $ \db ->
+            updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
 runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
-runNtfSMPWorker c srv doWork = forever $ do
-  void . atomically $ readTMVar doWork
-  getNtfToken >>= \case
-    Just NtfToken {ntfTknStatus} -> do
-      nextSub_ <- withStore c (`getNextNtfSubSMPAction` srv)
-      ts <- liftIO getCurrentTime
+runNtfSMPWorker c srv doWork = do
+  delay <- asks $ ntfSMPWorkerDelay . config
+  forever $ do
+    void . atomically $ readTMVar doWork
+    agentOperationBracket c AONtfNetwork runNtfSMPOperation
+    threadDelay delay
+  where
+    runNtfSMPOperation = do
+      nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
+      logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
       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
+        Just a@(NtfSubscription {connId}, _, _) -> do
+          ri <- asks $ reconnectInterval . config
+          withRetryInterval ri $ \loop ->
+            processAction a
+              `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
+    processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
+      ts <- liftIO getCurrentTime
+      unlessM (rescheduleAction doWork ts actionTs) $
+        case smpAction of
+          NSASmpKey ->
+            getNtfToken >>= \case
+              Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
+                rq <- withStore c (`getRcvQueue` connId)
+                C.SignAlg a <- asks (cmdSignAlg . config)
+                (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
+                (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
+                let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
+                withStore' c $ \db -> do
+                  setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
+                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NtfSubNTFAction NSACreate) ts
+                ns <- asks ntfSupervisor
+                atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
+              _ -> workerInternalError c connId "NSASmpKey - no active token"
+          NSASmpDelete -> do
+            rq_ <- withStore' c $ \db -> do
+              setRcvQueueNtfCreds db connId Nothing
+              getRcvQueue db connId
+            forM_ rq_ $ \rq -> disableQueueNotifications c rq
+            withStore' c $ \db -> deleteNtfSubscription db connId
 
-rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> NtfSubscription -> m Bool
-rescheduleAction doWork ts NtfSubscription {ntfSubActionTs}
-  | ntfSubActionTs <= ts = pure False
+rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
+rescheduleAction doWork ts actionTs
+  | actionTs <= ts = pure False
   | otherwise = do
     void . atomically $ tryTakeTMVar doWork
     void . forkIO $ do
-      threadDelay $ diffInMicros ntfSubActionTs ts
+      threadDelay $ diffInMicros actionTs ts
       void . atomically $ tryPutTMVar doWork ()
     pure True
 
@@ -209,10 +294,26 @@ 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)
+retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
+retryOnError c name loop done e = do
+  logError $ name <> " error: " <> tshow e
+  case e of
+    BROKER NETWORK -> retryLoop
+    BROKER TIMEOUT -> retryLoop
+    _ -> done e
+  where
+    retryLoop = do
+      atomically $ endAgentOperation c AONtfNetwork
+      atomically $ beginAgentOperation c AONtfNetwork
+      loop
+
+workerInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
+workerInternalError c connId internalErrStr = do
+  withStore' c $ \db -> setNullNtfSubscriptionAction db connId
+  notifyInternalError c connId internalErrStr
+
+notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
+notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
 
 getNtfToken :: AgentMonad m => m (Maybe NtfToken)
 getNtfToken = do
@@ -228,16 +329,20 @@ 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)
+    >>= mapM_
+      ( \NtfToken {ntfTknStatus, ntfMode} ->
+          when (ntfTknStatus == NTActive && ntfMode == NMInstant) $
+            writeTBQueue (ntfSubQ ns) cmd
+      )
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do
   cancelNtfWorkers_ $ ntfWorkers ns
   cancelNtfWorkers_ $ ntfSMPWorkers ns
 
-cancelNtfWorkers_ :: TMap ProtocolServer (TMVar (), Async ()) -> IO ()
+cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
 cancelNtfWorkers_ wsVar = do
-  ws <- atomically $ stateTVar wsVar $ \ws -> (ws, M.empty)
+  ws <- atomically $ stateTVar wsVar (,M.empty)
   forM_ ws $ uninterruptibleCancel . snd
 
 getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)

src/Simplex/Messaging/Agent/Protocol.hs

@@ -82,7 +82,8 @@ module Simplex.Messaging.Agent.Protocol
     QueueStatus (..),
     ACorrId,
     AgentMsgId,
-    AgentPhase (..),
+    NotificationsMode (..),
+    NotificationInfo (..),
 
     -- * Encode/decode
     serializeCommand,
@@ -119,9 +120,12 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.System (SystemTime)
 import Data.Time.ISO8601
 import Data.Type.Equality
 import Data.Typeable ()
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
 import Simplex.Messaging.Agent.QueryString
@@ -135,6 +139,7 @@ import Simplex.Messaging.Protocol
     MsgBody,
     MsgFlags,
     MsgId,
+    NMsgMeta,
     SMPServer,
     SndPublicVerifyKey,
     SrvLoc (..),
@@ -224,33 +229,39 @@ data ACommand (p :: AParty) where
   DEL :: ACommand Client
   OK :: ACommand Agent
   ERR :: AgentErrorType -> ACommand Agent
-  PHASE :: AgentPhase -> ACommand Agent
+  SUSPENDED :: 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
+data NotificationsMode = NMPeriodic | NMInstant
   deriving (Eq, Show)
 
-instance StrEncoding AgentPhase where
+instance StrEncoding NotificationsMode where
   strEncode = \case
-    APActive -> "ACTIVE"
-    APPaused -> "PAUSED"
-    APSuspended -> "SUSPENDED"
+    NMPeriodic -> "PERIODIC"
+    NMInstant -> "INSTANT"
   strP =
     A.takeTill (== ' ') >>= \case
-      "ACTIVE" -> pure APActive
-      "PAUSED" -> pure APPaused
-      "SUSPENDED" -> pure APSuspended
-      _ -> fail "bad AgentPhase"
+      "PERIODIC" -> pure NMPeriodic
+      "INSTANT" -> pure NMInstant
+      _ -> fail "bad NotificationsMode"
+
+instance ToJSON NotificationsMode where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance ToField NotificationsMode where toField = toField . strEncode
+
+instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP
+
+data NotificationInfo = NotificationInfo
+  { ntfConnId :: ConnId,
+    ntfTs :: SystemTime,
+    ntfMsgMeta :: Maybe NMsgMeta
+  }
+  deriving (Show)
 
 data ConnectionMode = CMInvitation | CMContact
   deriving (Eq, Show)
@@ -892,7 +903,7 @@ commandP =
     msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
     message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
     ackCmd = ACmd SClient . ACK <$> A.decimal
-    connections = strP `A.sepBy'` (A.char ',')
+    connections = strP `A.sepBy'` A.char ','
     msgMetaP = do
       integrity <- strP
       recipient <- " R=" *> partyMeta A.decimal
@@ -932,7 +943,7 @@ serializeCommand = \case
   CON -> "CON"
   ERR e -> "ERR " <> strEncode e
   OK -> "OK"
-  PHASE p -> "PHASE " <> strEncode p
+  SUSPENDED -> "SUSPENDED"
   where
     showTs :: UTCTime -> ByteString
     showTs = B.pack . formatISO8601Millis

src/Simplex/Messaging/Agent/Store.hs

@@ -9,9 +9,7 @@
 
 module Simplex.Messaging.Agent.Store where
 
-import Control.Concurrent.STM (TVar)
 import Control.Exception (Exception)
-import Crypto.Random (ChaChaDRG)
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Kind (Type)
@@ -19,9 +17,7 @@ import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys)
-import Simplex.Messaging.Notifications.Client
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfTknStatus, NtfTokenId)
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgFlags,
@@ -30,82 +26,13 @@ import Simplex.Messaging.Protocol
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
     RcvDhSecret,
+    RcvNtfDhSecret,
     RcvPrivateSignKey,
     SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Version
 
--- * Store management
-
--- | Store class type. Defines store access methods for implementations.
-class Monad m => MonadAgentStore s m where
-  -- Queue and Connection management
-  createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
-  createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
-  getConn :: s -> ConnId -> m SomeConn
-  getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn
-  deleteConn :: s -> ConnId -> m ()
-  upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()
-  upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()
-  setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
-  setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
-  setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
-  getRcvQueue :: s -> ConnId -> m RcvQueue
-
-  -- RcvQueue notifier key and ID
-  setRcvQueueNotifierKey :: s -> ConnId -> NtfPublicVerifyKey -> NtfPrivateSignKey -> m ()
-  setRcvQueueNotifierId :: s -> ConnId -> NotifierId -> m ()
-
-  -- Confirmations
-  createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
-  acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
-  getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
-  removeConfirmations :: s -> ConnId -> m ()
-  setHandshakeVersion :: s -> ConnId -> Version -> Bool -> m ()
-
-  -- Invitations - sent via Contact connections
-  createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
-  getInvitation :: s -> InvitationId -> m Invitation
-  acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()
-  deleteInvitation :: s -> ConnId -> InvitationId -> m ()
-
-  -- Msg management
-  updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
-  createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
-  updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
-  createSndMsg :: s -> ConnId -> SndMsgData -> m ()
-  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, PendingMsgData)
-  getPendingMsgs :: s -> ConnId -> m [InternalId]
-  setMsgUserAck :: s -> ConnId -> InternalId -> m MsgId
-  getLastMsg :: s -> ConnId -> SMP.MsgId -> m (Maybe RcvMsg)
-  deleteMsg :: s -> ConnId -> InternalId -> m ()
-
-  -- Double ratchet persistence
-  createRatchetX3dhKeys :: s -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
-  getRatchetX3dhKeys :: s -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
-  createRatchet :: s -> ConnId -> RatchetX448 -> m ()
-  getRatchet :: s -> ConnId -> m RatchetX448
-  getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys
-  updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
-
-  -- Notification device token persistence
-  createNtfToken :: s -> NtfToken -> m ()
-  getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
-  updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
-  updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
-  removeNtfToken :: s -> NtfToken -> m ()
-
-  -- Notification subscription persistence
-  getNtfSubscription :: s -> ConnId -> m (Maybe NtfSubscription)
-  createNtfSubscription :: s -> NtfSubscription -> NtfSubOrSMPAction -> m ()
-  markNtfSubscriptionForDeletion :: s -> ConnId -> m ()
-  updateNtfSubscription :: s -> ConnId -> NtfSubscription -> NtfSubOrSMPAction -> m ()
-  setNullNtfSubscriptionAction :: s -> ConnId -> m ()
-  deleteNtfSubscription :: s -> ConnId -> m ()
-  getNextNtfSubAction :: s -> NtfServer -> m (Maybe (NtfSubscription, NtfSubAction, RcvQueue))
-  getNextNtfSubSMPAction :: s -> SMPServer -> m (Maybe (NtfSubscription, NtfSubSMPAction, RcvQueue))
-
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
@@ -125,11 +52,19 @@ data RcvQueue = RcvQueue
     sndId :: Maybe SMP.SenderId,
     -- | queue status
     status :: QueueStatus,
-    -- | key pair to be used by the notification server to sign transmissions
-    ntfPublicKey :: Maybe NtfPublicVerifyKey,
-    ntfPrivateKey :: Maybe NtfPrivateSignKey,
+    -- | credentials used in context of notifications
+    clientNtfCreds :: Maybe ClientNtfCreds
+  }
+  deriving (Eq, Show)
+
+data ClientNtfCreds = ClientNtfCreds
+  { -- | key pair to be used by the notification server to sign transmissions
+    ntfPublicKey :: NtfPublicVerifyKey,
+    ntfPrivateKey :: NtfPrivateSignKey,
     -- | queue ID to be used by the notification server for NSUB command
-    notifierId :: Maybe NotifierId
+    notifierId :: NotifierId,
+    -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
+    rcvNtfDhSecret :: RcvNtfDhSecret
   }
   deriving (Eq, Show)
 

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

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

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

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

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

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

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

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

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

@@ -39,6 +39,7 @@ CREATE TABLE rcv_queues(
   ntf_public_key BLOB,
   ntf_private_key BLOB,
   ntf_id BLOB,
+  rcv_ntf_dh_secret BLOB,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -150,7 +151,7 @@ CREATE TABLE ntf_servers(
   PRIMARY KEY(ntf_host, ntf_port)
 ) WITHOUT ROWID;
 CREATE TABLE ntf_tokens(
-  provider TEXT NOT NULL, -- apn
+  provider TEXT NOT NULL, -- apns
   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,
@@ -163,14 +164,15 @@ tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
   tkn_status TEXT NOT NULL,
   tkn_action BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')), -- this is to check token status periodically to know when it was last checked
+  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  ntf_mode TEXT NULL, -- this is to check token status periodically to know when it was last checked
   PRIMARY KEY(provider, device_token, ntf_host, ntf_port),
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
 CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
 CREATE TABLE ntf_subscriptions(
-  conn_id BLOB NOT NULL, -- ? make nullable for when connection is deleted but we still need to delete subscription
+  conn_id BLOB NOT NULL,
   smp_host TEXT NULL,
   smp_port TEXT NULL,
   smp_ntf_id BLOB,
@@ -178,15 +180,13 @@ CREATE TABLE ntf_subscriptions(
   ntf_port TEXT NOT NULL,
   ntf_sub_id BLOB,
   ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubAction
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
   ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can(should) be not null in same record
   ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
   updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
   PRIMARY KEY(conn_id),
-  -- FOREIGN KEY(conn_id) REFERENCES connections
-  -- ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
   ON DELETE SET NULL ON UPDATE CASCADE,
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers

src/Simplex/Messaging/Client.hs

@@ -24,7 +24,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    ProtocolClient (sessionId),
+    ProtocolClient (thVersion, sessionId),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
@@ -36,6 +36,7 @@ module Simplex.Messaging.Client
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
+    disableSMPQueueNotifications,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
@@ -55,7 +56,7 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import Control.Monad.Trans.Class
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -82,7 +83,7 @@ data ProtocolClient msg = ProtocolClient
     connected :: TVar Bool,
     sessionId :: SessionId,
     thVersion :: Version,
-    protocolServer :: ProtocolServer,
+    protocolServer :: ProtoServer msg,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request msg),
@@ -94,7 +95,7 @@ data ProtocolClient msg = ProtocolClient
 type SMPClient = ProtocolClient SMP.BrokerMsg
 
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtocolServer, SessionId, QueueId, msg)
+type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
 
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
@@ -136,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 :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
 getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
   (atomically mkProtocolClient >>= runClient useTransport)
     `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
@@ -207,7 +208,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
       runExceptT $ sendProtocolCommand c Nothing "" protocolPing
 
     process :: ProtocolClient msg -> IO ()
-    process ProtocolClient {sessionId, rcvQ, sentCommands} = forever $ do
+    process c@ProtocolClient {rcvQ, sentCommands} = forever $ do
       (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
       if B.null $ bs corrId
         then sendMsg qId respOrErr
@@ -223,11 +224,11 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
                     Right r -> case protocolError r of
                       Just e -> Left $ PCEProtocolError e
                       _ -> Right r
-                  else Left PCEUnexpectedResponse
+                  else Left . PCEUnexpectedResponse $ bshow respOrErr
       where
         sendMsg :: QueueId -> Either ErrorType msg -> IO ()
         sendMsg qId = \case
-          Right cmd -> atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, qId, cmd)) msgQ
+          Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
           -- TODO send everything else to errQ and log in agent
           _ -> return ()
 
@@ -247,7 +248,7 @@ data ProtocolClientError
     -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
     -- other responses would result in this error.
     -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
-    PCEUnexpectedResponse
+    PCEUnexpectedResponse ByteString
   | -- | Used for TCP connection and command response timeouts.
     -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
     PCEResponseTimeout
@@ -275,30 +276,37 @@ createSMPQueue ::
 createSMPQueue c rpKey rKey dhKey =
   sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
     IDS qik -> pure qik
-    _ -> throwE PCEUnexpectedResponse
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
 subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
-subscribeSMPQueue c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+subscribeSMPQueue c rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
-    cmd@MSG {} ->
-      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
-    _ -> throwE PCEUnexpectedResponse
+    cmd@MSG {} -> writeSMPMessage c rId cmd
+    r -> throwE . PCEUnexpectedResponse $ bshow r
+
+writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> ExceptT ProtocolClientError IO ()
+writeSMPMessage c rId msg =
+  liftIO . atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
+
+serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
+serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
+  (protocolServer, thVersion, sessionId, entityId, message)
 
 -- | 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 =
+getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
+getSMPMessage c 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
+    cmd@(MSG msg) -> do
+      writeSMPMessage c rId cmd
+      pure $ Just msg
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Subscribe to the SMP queue notifications.
 --
@@ -315,11 +323,17 @@ secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
-enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT ProtocolClientError IO NotifierId
-enableSMPQueueNotifications c rpKey rId notifierKey =
-  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
-    NID nId -> pure nId
-    _ -> throwE PCEUnexpectedResponse
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
+enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
+  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
+    NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
+    r -> throwE . PCEUnexpectedResponse $ bshow r
+
+-- | Disable notifications for the queue for push notifications server.
+--
+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
+disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
+disableSMPQueueNotifications = okSMPCommand NDEL
 
 -- | Send SMP message.
 --
@@ -328,18 +342,17 @@ sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -
 sendSMPMessage c spKey sId flags msg =
   sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
-    _ -> throwE PCEUnexpectedResponse
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
 ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
-ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId msgId =
+ackSMPMessage c rpKey rId msgId =
   sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
-    cmd@MSG {} ->
-      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
-    _ -> throwE PCEUnexpectedResponse
+    cmd@MSG {} -> writeSMPMessage c rId cmd
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Irreversibly suspend SMP queue.
 -- The existing messages from the queue will still be delivered.
@@ -358,14 +371,14 @@ okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> Queue
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
-    _ -> throwE PCEUnexpectedResponse
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Send SMP command
 sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
 sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
 -- | Send Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
+sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
 sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
   corrId <- lift_ getNextCorrId
   t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)

src/Simplex/Messaging/Client/Agent.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Client.Agent where
@@ -28,7 +29,8 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (catchAll_, tryE, whenM, ($>>=))
+import Simplex.Messaging.Transport
+import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
 import System.Timeout (timeout)
 import UnliftIO (async, forConcurrently_)
 import UnliftIO.Exception (Exception)
@@ -45,7 +47,7 @@ data SMPClientAgentEvent
   | CASubError SMPServer SMPSub ProtocolClientError
 
 data SMPSubParty = SPRecipient | SPNotifier
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 type SMPSub = (SMPSubParty, QueueId)
 
@@ -61,7 +63,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
 defaultSMPClientAgentConfig :: SMPClientAgentConfig
 defaultSMPClientAgentConfig =
   SMPClientAgentConfig
-    { smpCfg = defaultClientConfig,
+    { smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
       reconnectInterval =
         RetryInterval
           { initialInterval = second,
@@ -201,7 +203,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
         notify $ CAReconnected srv
         cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
         forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          whenM (atomically $ hasSub (srvSubs ca) srv s) $
+          unlessM (atomically $ hasSub (srvSubs ca) srv s) $
             subscribe_ smp sub `catchE` handleError s
       where
         subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()

src/Simplex/Messaging/Crypto.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -101,6 +102,7 @@ module Simplex.Messaging.Crypto
     -- * NaCl crypto_box
     CbNonce (unCbNonce),
     cbEncrypt,
+    cbEncryptMaxLenBS,
     cbDecrypt,
     cbNonce,
     randomCbNonce,
@@ -118,6 +120,13 @@ module Simplex.Messaging.Crypto
 
     -- * Cryptography error type
     CryptoError (..),
+
+    -- * Limited size ByteStrings
+    MaxLenBS,
+    pattern MaxLenBS,
+    maxLenBS,
+    unsafeMaxLenBS,
+    appendMaxLenBS,
   )
 where
 
@@ -153,11 +162,11 @@ import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
 import Data.String
 import Data.Type.Equality
-import Data.Typeable (Typeable)
+import Data.Typeable (Proxy (Proxy), Typeable)
 import Data.X509
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.TypeLits (ErrorMessage (..), TypeError)
+import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -250,6 +259,12 @@ deriving instance Eq (PrivateKey a)
 
 deriving instance Show (PrivateKey a)
 
+instance StrEncoding (PrivateKey X25519) where
+  strEncode = strEncode . encodePrivKey
+  {-# INLINE strEncode #-}
+  strDecode = decodePrivKey
+  {-# INLINE strDecode #-}
+
 data APrivateKey
   = forall a.
     AlgorithmI a =>
@@ -296,6 +311,12 @@ instance Encoding APrivateSignKey where
   smpDecode = decodePrivKey
   {-# INLINE smpDecode #-}
 
+instance StrEncoding APrivateSignKey where
+  strEncode = strEncode . encodePrivKey
+  {-# INLINE strEncode #-}
+  strDecode = decodePrivKey
+  {-# INLINE strDecode #-}
+
 data APublicVerifyKey
   = forall a.
     (AlgorithmI a, SignatureAlgorithm a) =>
@@ -797,6 +818,41 @@ unPad padded
     (lenWrd, rest) = B.splitAt 2 padded
     len = fromIntegral $ decodeWord16 lenWrd
 
+newtype MaxLenBS (i :: Nat) = MLBS {unMaxLenBS :: ByteString}
+
+pattern MaxLenBS :: ByteString -> MaxLenBS i
+pattern MaxLenBS s <- MLBS s
+
+{-# COMPLETE MaxLenBS #-}
+
+instance KnownNat i => Encoding (MaxLenBS i) where
+  smpEncode (MLBS s) = smpEncode s
+  smpP = first show . maxLenBS <$?> smpP
+
+instance KnownNat i => StrEncoding (MaxLenBS i) where
+  strEncode (MLBS s) = strEncode s
+  strP = first show . maxLenBS <$?> strP
+
+maxLenBS :: forall i. KnownNat i => ByteString -> Either CryptoError (MaxLenBS i)
+maxLenBS s
+  | B.length s > maxLength @i = Left CryptoLargeMsgError
+  | otherwise = Right $ MLBS s
+
+unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
+unsafeMaxLenBS = MLBS
+
+padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
+padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
+  where
+    len = B.length msg
+    padLen = maxLength @i - len
+
+appendMaxLenBS :: (KnownNat i, KnownNat j) => MaxLenBS i -> MaxLenBS j -> MaxLenBS (i + j)
+appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
+
+maxLength :: forall i. KnownNat i => Int
+maxLength = fromIntegral (natVal $ Proxy @i)
+
 initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEAD (Key aesKey) (IV ivBytes) = do
   iv <- makeIV @c ivBytes
@@ -852,12 +908,17 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 
 -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
 cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
-cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox <$> pad msg paddedLen
+cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
+
+-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
+cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
+cbEncryptMaxLenBS secret (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
+
+cryptoBox :: DhSecret 'X25519 -> ByteString -> ByteString -> ByteString
+cryptoBox secret nonce s = BA.convert tag <> c
   where
-    cryptoBox s = BA.convert tag <> c
-      where
-        (rs, c) = xSalsa20 secret nonce s
-        tag = Poly1305.auth rs c
+    (rs, c) = xSalsa20 secret nonce s
+    tag = Poly1305.auth rs c
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
@@ -871,7 +932,7 @@ cbDecrypt secret (CbNonce nonce) packet
     tag = Poly1305.auth rs c
 
 newtype CbNonce = CbNonce {unCbNonce :: ByteString}
-  deriving (Show)
+  deriving (Eq, Show)
 
 instance StrEncoding CbNonce where
   strEncode (CbNonce s) = strEncode s

src/Simplex/Messaging/Encoding.hs

@@ -197,3 +197,9 @@ instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f
   {-# INLINE smpEncode #-}
   smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
+
+instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
+  smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
+  {-# INLINE smpEncode #-}
+  smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+  {-# INLINE smpP #-}

src/Simplex/Messaging/Encoding/String.hs

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

src/Simplex/Messaging/Notifications/Client.hs

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

src/Simplex/Messaging/Notifications/Protocol.hs

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

src/Simplex/Messaging/Notifications/Server.hs

@@ -10,6 +10,7 @@
 
 module Simplex.Messaging.Notifications.Server where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
@@ -17,25 +18,29 @@ import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
 import Data.Functor (($>))
+import Data.Map.Strict (Map)
 import qualified Data.Text as T
 import Data.Time.Clock.System (getSystemTime)
 import Network.Socket (ServiceName)
+import Simplex.Messaging.Client (ProtocolClientError (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
 import Simplex.Messaging.Notifications.Server.Store
+import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
 import Simplex.Messaging.Transport.Server (runTransportServer)
 import Simplex.Messaging.Util
-import UnliftIO (async, uninterruptibleCancel)
-import UnliftIO.Concurrent (forkFinally, threadDelay)
+import System.Mem.Weak (deRefWeak)
+import UnliftIO (IOMode (..), async, uninterruptibleCancel)
+import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
 import UnliftIO.Exception
 import UnliftIO.STM
 
@@ -51,7 +56,9 @@ ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfi
 ntfServer NtfServerConfig {transports} started = do
   s <- asks subscriber
   ps <- asks pushServer
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
+  subs <- readTVarIO =<< asks (subscriptions . store)
+  void . forkIO $ resubscribe s subs
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports) `finally` stopServer
   where
     runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
@@ -65,6 +72,20 @@ ntfServer NtfServerConfig {transports} started = do
         Right th -> runNtfClientTransport th
         Left _ -> pure ()
 
+    stopServer :: m ()
+    stopServer = do
+      withNtfLog closeStoreLog
+      asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
+
+resubscribe :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> m ()
+resubscribe NtfSubscriber {newSubQ} subs = do
+  d <- asks $ resubscribeDelay . config
+  forM_ subs $ \sub@NtfSubData {} ->
+    whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
+      atomically $ writeTBQueue newSubQ $ NtfSub sub
+      threadDelay d
+  liftIO $ logInfo "SMP connections resubscribed"
+
 ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
 ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
   raceAny_ [subscribe, receiveSMP, receiveAgent]
@@ -75,44 +96,50 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
         atomically (readTBQueue newSubQ) >>= \case
           sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
             SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
-            atomically $ writeTBQueue subscriberSubQ sub
+            atomically $ writeTQueue 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 ()
+          sub@SMPSubscriber {subThreadId} <- atomically newSMPSubscriber
+          atomically $ TM.insert smpServer sub smpSubscribers
+          tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub)
+          atomically . writeTVar subThreadId $ Just tId
+          pure sub
 
     runSMPSubscriber :: SMPSubscriber -> m ()
     runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
       forever $
-        atomically (peekTBQueue subscriberSubQ) >>= \case
-          NtfSub NtfSubData {smpQueue, notifierKey} -> do
+        atomically (peekTQueue subscriberSubQ)
+          >>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
+            updateSubStatus smpQueue NSPending
             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 ()
+                updateSubStatus smpQueue NSActive
+                void . atomically $ readTQueue subscriberSubQ
+              Left err -> do
+                handleSubError smpQueue err
+                case err of
+                  PCEResponseTimeout -> pure ()
+                  PCENetworkError -> pure ()
+                  _ -> void . atomically $ readTQueue subscriberSubQ
 
     receiveSMP :: m ()
     receiveSMP = forever $ do
-      (srv, _sessId, ntfId, msg) <- atomically $ readTBQueue msgQ
+      (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
+      let smpQueue = SMPQueueNtf srv ntfId
       case msg of
-        SMP.NMSG -> do
-          NtfPushServer {pushQ} <- asks pushServer
+        SMP.NMSG nmsgNonce encNMsgMeta -> do
+          ntfTs <- liftIO getSystemTime
           st <- asks store
+          NtfPushServer {pushQ} <- asks pushServer
           atomically $
-            findNtfSubscriptionToken st (SMPQueueNtf srv ntfId)
-              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage srv ntfId))
+            findNtfSubscriptionToken st smpQueue
+              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
+        SMP.END -> updateSubStatus smpQueue NSEnd
         _ -> pure ()
       pure ()
 
@@ -120,39 +147,88 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       forever $
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
-          CADisconnected _srv _subs -> do
-            -- update subscription statuses
-            pure ()
-          CAReconnected _ -> pure ()
-          CAResubscribed _srv _sub -> do
-            -- update subscription status
-            pure ()
-          CASubError _srv _sub _err -> do
-            -- update subscription status
-            pure ()
+          CADisconnected srv subs -> do
+            logInfo . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
+            forM_ subs $ \(_, ntfId) -> do
+              let smpQueue = SMPQueueNtf srv ntfId
+              updateSubStatus smpQueue NSInactive
+          CAReconnected srv ->
+            logInfo $ "SMP server reconnected " <> T.pack (host srv)
+          CAResubscribed srv sub -> do
+            let ntfId = snd sub
+                smpQueue = SMPQueueNtf srv ntfId
+            updateSubStatus smpQueue NSActive
+          CASubError srv (_, ntfId) err -> do
+            logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
+            handleSubError (SMPQueueNtf srv ntfId) err
 
-ntfPush :: MonadUnliftIO m => NtfPushServer -> m ()
-ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
-  (tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  logDebug $ "sending push notification to " <> T.pack (show pp)
+    handleSubError :: SMPQueueNtf -> ProtocolClientError -> m ()
+    handleSubError smpQueue = \case
+      PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
+      PCEProtocolError e -> updateErr "SMP error " e
+      PCEIOError e -> updateErr "IOError " e
+      PCEResponseError e -> updateErr "ResponseError " e
+      PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
+      PCETransportError e -> updateErr "TransportError " e
+      PCESignatureError e -> updateErr "SignatureError " e
+      PCEResponseTimeout -> pure ()
+      PCENetworkError -> pure ()
+      where
+        updateErr :: Show e => ByteString -> e -> m ()
+        updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
+
+    updateSubStatus smpQueue status = do
+      st <- asks store
+      atomically (findNtfSubscription st smpQueue)
+        >>= mapM_
+          ( \NtfSubData {ntfSubId, subStatus} -> do
+              atomically $ writeTVar subStatus status
+              withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status
+          )
+
+ntfPush :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfPushServer -> m ()
+ntfPush s@NtfPushServer {pushQ} = forever $ do
+  (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   status <- readTVarIO tknStatus
   case (status, ntf) of
     (_, PNVerification _) -> do
       -- TODO check token status
-      deliverNotification pp tkn ntf
-      atomically $ modifyTVar tknStatus $ \status' -> if status' == NTActive then NTActive else NTConfirmed
+      deliverNotification pp tkn ntf >>= \case
+        Right _ -> do
+          status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
+          forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
+        _ -> pure ()
     (NTActive, PNCheckMessages) -> do
-      deliverNotification pp tkn ntf
-    (NTActive, PNMessage _ _) -> do
-      deliverNotification pp tkn ntf
+      void $ deliverNotification pp tkn ntf
+    (NTActive, PNMessage {}) -> do
+      void $ deliverNotification pp tkn ntf
     _ -> do
-      logError "bad notification token status"
+      liftIO $ logError "bad notification token status"
   where
-    deliverNotification :: PushProvider -> PushProviderClient
-    deliverNotification pp tkn ntf = do
+    deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> m (Either PushProviderError ())
+    deliverNotification pp tkn@NtfTknData {ntfTknId, tknStatus} ntf = do
       deliver <- liftIO $ getPushClient s pp
-      -- TODO retry later based on the error
-      deliver tkn ntf `catchError` \e -> logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e
+      liftIO (runExceptT $ deliver tkn ntf) >>= \case
+        Right _ -> pure $ Right ()
+        Left e -> case e of
+          PPConnection _ -> retryDeliver
+          PPRetryLater -> retryDeliver
+          -- TODO alert
+          PPCryptoError _ -> err e
+          PPResponseError _ _ -> err e
+          PPTokenInvalid -> updateTknStatus NTInvalid >> err e
+          PPPermanentError -> err e
+      where
+        retryDeliver :: m (Either PushProviderError ())
+        retryDeliver = do
+          deliver <- liftIO $ newPushClient s pp
+          liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
+        updateTknStatus :: NtfTknStatus -> m ()
+        updateTknStatus status = do
+          atomically $ writeTVar tknStatus status
+          withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
+        err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
 
 runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
 runNtfClientTransport th@THandle {sessionId} = do
@@ -250,7 +326,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
     verifyToken' t_ = verifyToken t_ . const
 
 client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
-client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ, intervalNotifiers} =
+client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
@@ -265,12 +341,12 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ
         let dhSecret = C.dh' dhPubKey srvDhPrivKey
         tknId <- getId
         regCode <- getRegCode
-        atomically $ do
-          tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
-          addNtfToken st tknId tkn
-          writeTBQueue pushQ (tkn, PNVerification regCode)
+        tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode
+        atomically $ addNtfToken st tknId tkn
+        atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
+        withNtfLog (`logCreateToken` tkn)
         pure (corrId, "", NRTknId tknId srvDhPubKey)
-      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (corrId, tknId, cmd) -> do
+      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
         (corrId,tknId,) <$> case cmd of
           TNEW (NewNtfTkn _ _ dhPubKey) -> do
@@ -289,31 +365,53 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ
               atomically $ writeTVar tknStatus NTActive
               tIds <- atomically $ removeInactiveTokenRegistrations st tkn
               forM_ tIds cancelInvervalNotifications
+              withNtfLog $ \s -> logTokenStatus s tknId NTActive
               pure NROk
             | otherwise -> do
               logDebug "TVFY - incorrect code or token status"
               pure $ NRErr AUTH
-          TCHK -> pure $ NRTkn status
+          TCHK -> do
+            logDebug "TCHK"
+            pure $ NRTkn status
+          TRPL token' -> do
+            logDebug "TRPL - replace token"
+            st <- asks store
+            regCode <- getRegCode
+            atomically $ do
+              removeTokenRegistration st tkn
+              writeTVar tknStatus NTRegistered
+              let tkn' = tkn {token = token', tknRegCode = regCode}
+              addNtfToken st tknId tkn'
+              writeTBQueue pushQ (tkn', PNVerification regCode)
+            withNtfLog $ \s -> logUpdateToken s tknId token' regCode
+            pure NROk
           TDEL -> do
             logDebug "TDEL"
             st <- asks store
-            atomically $ deleteNtfToken st tknId
+            qs <- atomically $ deleteNtfToken st tknId
+            forM_ qs $ \SMPQueueNtf {smpServer, notifierId} ->
+              atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             cancelInvervalNotifications tknId
+            withNtfLog (`logDeleteToken` tknId)
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
+            atomically $ writeTVar tknCronInterval 0
             cancelInvervalNotifications tknId
+            withNtfLog $ \s -> logTokenCron s tknId 0
             pure NROk
           TCRN int
             | int < 20 -> pure $ NRErr QUOTA
             | otherwise -> do
               logDebug "TCRN"
+              atomically $ writeTVar tknCronInterval int
               atomically (TM.lookup tknId intervalNotifiers) >>= \case
                 Nothing -> runIntervalNotifier int
                 Just IntervalNotifier {interval, action} ->
                   unless (interval == int) $ do
                     uninterruptibleCancel action
                     runIntervalNotifier int
+              withNtfLog $ \s -> logTokenCron s tknId int
               pure NROk
             where
               runIntervalNotifier interval = do
@@ -328,14 +426,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ
         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
+        sub <- atomically $ mkNtfSubData subId newSub
+        resp <-
+          atomically (addNtfSubscription st subId sub) >>= \case
+            Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
+            _ -> pure $ NRErr AUTH
+        withNtfLog (`logCreateSubscription` sub)
+        pure (corrId, "", resp)
+      NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
           SNEW (NewNtfSub _ _ notifierKey) -> do
@@ -345,8 +443,16 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ
               if notifierKey == registeredNKey
                 then NRSubId subId
                 else NRErr AUTH
-          SCHK -> pure $ NRSub status
-          SDEL -> pure NROk
+          SCHK -> do
+            logDebug "SCHK"
+            pure $ NRSub status
+          SDEL -> do
+            logDebug "SDEL"
+            st <- asks store
+            atomically $ deleteNtfSubscription st subId
+            atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
+            withNtfLog (`logDeleteSubscription` subId)
+            pure NROk
           PING -> pure NRPong
     getId :: m NtfEntityId
     getId = getRandomBytes =<< asks (subIdBytes . config)
@@ -361,44 +467,5 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ} NtfPushServer {pushQ
       atomically (TM.lookupDelete tknId intervalNotifiers)
         >>= mapM_ (uninterruptibleCancel . action)
 
--- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk)
--- do
--- st <- asks store
--- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
--- let dhSecret = C.dh' dhPubKey privDhKey
--- sub <- atomically $ mkNtfSubsciption smpQueue token verifyKey dhSecret
--- addSubRetry 3 st sub >>= \case
---   Nothing -> pure (corrId, "", NRErr INTERNAL)
---   Just sId -> do
---     atomically $ writeTBQueue subQ sub
---     pure (corrId, sId, NRSubId pubDhKey)
--- where
---   addSubRetry :: Int -> NtfSubscriptionsStore -> NtfSubsciption -> m (Maybe NtfSubsciptionId)
---   addSubRetry 0 _ _ = pure Nothing
---   addSubRetry n st sub = do
---     sId <- getId
---     -- create QueueRec record with these ids and keys
---     atomically (addNtfSub st sId sub) >>= \case
---       Nothing -> addSubRetry (n - 1) st sub
---       _ -> pure $ Just sId
---   getId :: m NtfSubsciptionId
---   getId = do
---     n <- asks $ subIdBytes . config
---     gVar <- asks idsDrg
---     atomically (randomBytes n gVar)
--- NReqCommand sub@NtfSubsciption {tokenId, subStatus} (corrId, subId, cmd) ->
---   (corrId,subId,) <$> case cmd of
---     NCSubCreate tokenId smpQueue -> pure NROk
--- do
---   st <- asks store
---   (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
---   let dhSecret = C.dh' (dhPubKey newSub) privDhKey
---   atomically (updateNtfSub st sub newSub dhSecret) >>= \case
---     Nothing -> pure $ NRErr INTERNAL
---     _ -> atomically $ do
---       whenM ((== NSEnd) <$> readTVar status) $ writeTBQueue subQ sub
---       pure $ NRSubId pubDhKey
--- NCSubCheck -> NRStat <$> readTVarIO subStatus
--- NCSubDelete -> do
---   st <- asks store
---   atomically (deleteNtfSub st subId) $> NROk
+withNtfLog :: (MonadUnliftIO m, MonadReader NtfEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
+withNtfLog action = liftIO . mapM_ action =<< asks storeLog

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

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

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

@@ -10,6 +10,7 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
+import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Crypto.Hash.Algorithms (SHA256 (..))
@@ -46,7 +47,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
-import Simplex.Messaging.Protocol (NotifierId, SMPServer)
+import Simplex.Messaging.Protocol (EncNMsgMeta)
 import Simplex.Messaging.Transport.HTTP2.Client
 import System.Environment (getEnv)
 import UnliftIO.STM
@@ -95,9 +96,25 @@ readECPrivateKey f = do
 
 data PushNotification
   = PNVerification NtfRegCode
-  | PNMessage SMPServer NotifierId
+  | PNMessage PNMessageData
   | PNAlert Text
   | PNCheckMessages
+  deriving (Show)
+
+data PNMessageData = PNMessageData
+  { smpQueue :: SMPQueueNtf,
+    ntfTs :: SystemTime,
+    nmsgNonce :: C.CbNonce,
+    encNMsgMeta :: EncNMsgMeta
+  }
+  deriving (Show)
+
+instance StrEncoding PNMessageData where
+  strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
+    strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
+  strP = do
+    (smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
+    pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
 
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show, Generic)
@@ -107,9 +124,9 @@ instance ToJSON APNSNotification where
   toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
 data APNSNotificationBody
-  = APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
-  | APNSBackground {contentAvailable :: Int}
+  = APNSBackground {contentAvailable :: Int}
   | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text}
+  | APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
   deriving (Show, Generic)
 
 apnsJSONOptions :: J.Options
@@ -176,23 +193,27 @@ data APNSPushClientConfig = APNSPushClientConfig
     paddedNtfLength :: Int,
     appName :: ByteString,
     appTeamId :: Text,
-    apnsHost :: HostName,
     apnsPort :: ServiceName,
     http2cfg :: HTTP2ClientConfig
   }
   deriving (Show)
 
+apnsProviderHost :: PushProvider -> HostName
+apnsProviderHost = \case
+  PPApnsTest -> "localhost"
+  PPApnsDev -> "api.sandbox.push.apple.com"
+  PPApnsProd -> "api.push.apple.com"
+
 defaultAPNSPushClientConfig :: APNSPushClientConfig
 defaultAPNSPushClientConfig =
   APNSPushClientConfig
-    { tokenTTL = 1200, -- 20 minutes
+    { tokenTTL = 1800, -- 30 minutes
       authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
       authKeyAlg = "ES256",
       authKeyIdEnv = "APNS_KEY_ID",
-      paddedNtfLength = 256,
+      paddedNtfLength = 512,
       appName = "chat.simplex.app",
       appTeamId = "5NN7GUYB6T",
-      apnsHost = "api.sandbox.push.apple.com",
       apnsPort = "443",
       http2cfg = defaultHTTP2ClientConfig
     }
@@ -203,19 +224,20 @@ data APNSPushClient = APNSPushClient
     jwtHeader :: JWTHeader,
     jwtToken :: TVar (JWTToken, SignedJWTToken),
     nonceDrg :: TVar ChaChaDRG,
+    apnsHost :: HostName,
     apnsCfg :: APNSPushClientConfig
   }
 
-createAPNSPushClient :: APNSPushClientConfig -> IO APNSPushClient
-createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
+createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
+createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
   https2Client <- newTVarIO Nothing
-  void $ connectHTTPS2 apnsCfg https2Client
+  void $ connectHTTPS2 apnsHost apnsCfg https2Client
   privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
   let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
   nonceDrg <- drgNew >>= newTVarIO
-  pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsCfg}
+  pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
 
 getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
 getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do
@@ -236,8 +258,8 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
   signedJWT <- signedJWTToken privateKey jwt
   pure (jwt, signedJWT)
 
-connectHTTPS2 :: APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
-connectHTTPS2 APNSPushClientConfig {apnsHost, apnsPort, http2cfg} https2Client = do
+connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
+connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
   r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
   case r of
     Right client -> atomically . writeTVar https2Client $ Just client
@@ -247,28 +269,31 @@ connectHTTPS2 APNSPushClientConfig {apnsHost, apnsPort, http2cfg} https2Client =
     disconnected = atomically $ writeTVar https2Client Nothing
 
 getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
-getApnsHTTP2Client APNSPushClient {https2Client, apnsCfg} =
-  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right)
+getApnsHTTP2Client APNSPushClient {https2Client, apnsHost, apnsCfg} =
+  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsHost apnsCfg https2Client) (pure . Right)
 
 disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
 disconnectApnsHTTP2Client APNSPushClient {https2Client} =
   readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
 
+ntfCategoryCheckMessage :: Text
+ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
+
 apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
 apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
   PNVerification (NtfRegCode code) ->
     encrypt code $ \code' ->
-      apn APNSBackground {contentAvailable = 1} . Just $ J.object ["verification" .= code', "nonce" .= nonce]
-  PNMessage srv nId ->
-    encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue ->
-      apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue, "nonce" .= nonce]
+      apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
+  PNMessage pnMessageData ->
+    encrypt (strEncode pnMessageData) $ \ntfData ->
+      apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
   PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
   PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
   where
     encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
     encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
     apn aps notificationData = APNSNotification {aps, notificationData}
-    apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or some other app event", category = Nothing}
+    apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or another app event", category = Just ntfCategoryCheckMessage}
     apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
     safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?'
 
@@ -298,7 +323,7 @@ data PushProviderError
   | PPTokenInvalid
   | PPRetryLater
   | PPPermanentError
-  deriving (Show)
+  deriving (Show, Exception)
 
 type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
 
@@ -307,7 +332,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
   deriving (Generic, FromJSON)
 
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApns tknStr} pn = do
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn

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

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

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

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

src/Simplex/Messaging/Notifications/Transport.hs

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

src/Simplex/Messaging/Notifications/Types.hs

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

src/Simplex/Messaging/Protocol.hs

@@ -16,9 +16,13 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
+{-# HLINT ignore "Use newtype instead of data" #-}
+
 -- |
 -- Module      : Simplex.Messaging.ProtocolEncoding
 -- Copyright   : (c) simplex.chat
@@ -59,9 +63,13 @@ module Simplex.Messaging.Protocol
     ClientMessage (..),
     PrivHeader (..),
     Protocol (..),
+    ProtocolType (..),
     ProtocolServer (..),
+    ProtoServer,
     SMPServer,
     pattern SMPServer,
+    NtfServer,
+    pattern NtfServer,
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -76,9 +84,22 @@ module Simplex.Messaging.Protocol
     SndPublicVerifyKey,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
+    RcvNtfPublicDhKey,
+    RcvNtfDhSecret,
+    Message (..),
+    RcvMessage (..),
     MsgId,
     MsgBody,
+    MaxMessageLen,
+    MaxRcvMessageLen,
+    EncRcvMsgBody (..),
+    RcvMsgBody (..),
+    ClientRcvMsgBody (..),
+    EncNMsgMeta,
+    SMPMsgMeta (..),
+    NMsgMeta (..),
     MsgFlags (..),
+    rcvMessageMeta,
     noMsgFlags,
 
     -- * Parse and serialize
@@ -87,6 +108,8 @@ module Simplex.Messaging.Protocol
     encodeTransmission,
     transmissionP,
     _smpP,
+    encodeRcvMsgBody,
+    clientRcvMsgBodyP,
 
     -- * TCP transport functions
     tPut,
@@ -109,9 +132,10 @@ import qualified Data.ByteString.Char8 as B
 import Data.Kind
 import Data.Maybe (isNothing)
 import Data.String
-import Data.Time.Clock.System (SystemTime)
+import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
 import GHC.Generics (Generic)
+import GHC.TypeLits (type (+))
 import Generic.Random (genericArbitraryU)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
@@ -132,6 +156,11 @@ smpClientVRange = mkVersionRange 1 smpClientVersion
 maxMessageLength :: Int
 maxMessageLength = 16088
 
+type MaxMessageLen = 16088
+
+-- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
+type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
+
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
 e2eEncConfirmationLength = 15936
@@ -215,7 +244,8 @@ data Command (p :: Party) where
   NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
-  NKEY :: NtfPublicVerifyKey -> Command Recipient
+  NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
+  NDEL :: Command Recipient
   GET :: Command Recipient
   -- ACK v1 has to be supported for encoding/decoding
   -- ACK :: Command Recipient
@@ -237,20 +267,124 @@ deriving instance Eq (Command p)
 data BrokerMsg where
   -- SMP broker messages (responses, client messages, notifications)
   IDS :: QueueIdsKeys -> 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
+  -- MSG v1/2 has to be supported for encoding/decoding
+  -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
+  MSG :: RcvMessage -> BrokerMsg
+  NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
+  NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
   END :: BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
   deriving (Eq, Show)
 
-newtype MsgFlags = MsgFlags {notification :: Bool}
+data RcvMessage = RcvMessage
+  { msgId :: MsgId,
+    msgTs :: SystemTime,
+    msgFlags :: MsgFlags,
+    msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
+  }
   deriving (Eq, Show)
 
+-- | received message without server/recipient encryption
+data Message = Message
+  { msgId :: MsgId,
+    msgTs :: SystemTime,
+    msgFlags :: MsgFlags,
+    msgBody :: C.MaxLenBS MaxMessageLen
+  }
+
+instance StrEncoding RcvMessage where
+  strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
+    B.unwords
+      [ strEncode msgId,
+        strEncode msgTs,
+        "flags=" <> strEncode msgFlags,
+        strEncode body
+      ]
+  strP = do
+    msgId <- strP_
+    msgTs <- strP_
+    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
+    msgBody <- EncRcvMsgBody <$> strP
+    pure RcvMessage {msgId, msgTs, msgFlags, msgBody}
+
+newtype EncRcvMsgBody = EncRcvMsgBody ByteString
+  deriving (Eq, Show)
+
+data RcvMsgBody = RcvMsgBody
+  { msgTs :: SystemTime,
+    msgFlags :: MsgFlags,
+    msgBody :: C.MaxLenBS MaxMessageLen
+  }
+
+encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
+encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody} =
+  let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
+   in C.appendMaxLenBS rcvMeta msgBody
+
+data ClientRcvMsgBody = ClientRcvMsgBody
+  { msgTs :: SystemTime,
+    msgFlags :: MsgFlags,
+    msgBody :: ByteString
+  }
+
+clientRcvMsgBodyP :: Parser ClientRcvMsgBody
+clientRcvMsgBodyP = do
+  msgTs <- smpP
+  msgFlags <- smpP
+  Tail msgBody <- _smpP
+  pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
+
+instance StrEncoding Message where
+  strEncode Message {msgId, msgTs, msgFlags, msgBody} =
+    B.unwords
+      [ strEncode msgId,
+        strEncode msgTs,
+        "flags=" <> strEncode msgFlags,
+        strEncode msgBody
+      ]
+  strP = do
+    msgId <- strP_
+    msgTs <- strP_
+    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
+    msgBody <- strP
+    pure Message {msgId, msgTs, msgFlags, msgBody}
+
+type EncNMsgMeta = ByteString
+
+data SMPMsgMeta = SMPMsgMeta
+  { msgId :: MsgId,
+    msgTs :: SystemTime,
+    msgFlags :: MsgFlags
+  }
+  deriving (Show)
+
+rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
+rcvMessageMeta msgId ClientRcvMsgBody {msgTs, msgFlags} = SMPMsgMeta {msgId, msgTs, msgFlags}
+
+data NMsgMeta = NMsgMeta
+  { msgId :: MsgId,
+    msgTs :: SystemTime
+  }
+  deriving (Show)
+
+instance Encoding NMsgMeta where
+  smpEncode NMsgMeta {msgId, msgTs} =
+    smpEncode (msgId, msgTs)
+  smpP = do
+    -- Tail here is to allow extension in the future clients/servers
+    (msgId, msgTs, Tail _) <- smpP
+    pure NMsgMeta {msgId, msgTs}
+
+-- it must be data for correct JSON encoding
+data MsgFlags = MsgFlags {notification :: Bool}
+  deriving (Eq, Show, Generic)
+
+instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions
+
+-- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
 instance Encoding MsgFlags where
   smpEncode MsgFlags {notification} = smpEncode notification
   smpP = do
@@ -273,6 +407,7 @@ data CommandTag (p :: Party) where
   SUB_ :: CommandTag Recipient
   KEY_ :: CommandTag Recipient
   NKEY_ :: CommandTag Recipient
+  NDEL_ :: CommandTag Recipient
   GET_ :: CommandTag Recipient
   ACK_ :: CommandTag Recipient
   OFF_ :: CommandTag Recipient
@@ -312,6 +447,7 @@ instance PartyI p => Encoding (CommandTag p) where
     SUB_ -> "SUB"
     KEY_ -> "KEY"
     NKEY_ -> "NKEY"
+    NDEL_ -> "NDEL"
     GET_ -> "GET"
     ACK_ -> "ACK"
     OFF_ -> "OFF"
@@ -327,6 +463,7 @@ instance ProtocolMsgTag CmdTag where
     "SUB" -> Just $ CT SRecipient SUB_
     "KEY" -> Just $ CT SRecipient KEY_
     "NKEY" -> Just $ CT SRecipient NKEY_
+    "NDEL" -> Just $ CT SRecipient NDEL_
     "GET" -> Just $ CT SRecipient GET_
     "ACK" -> Just $ CT SRecipient ACK_
     "OFF" -> Just $ CT SRecipient OFF_
@@ -413,41 +550,109 @@ instance Encoding ClientMessage where
   smpEncode (ClientMessage h msg) = smpEncode h <> msg
   smpP = ClientMessage <$> smpP <*> A.takeByteString
 
-type SMPServer = ProtocolServer
+type SMPServer = ProtocolServer 'PSMP
 
-pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer
-pattern SMPServer host port keyHash = ProtocolServer host port keyHash
+pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
+pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
--- | SMP server location and transport key digest (hash).
-data ProtocolServer = ProtocolServer
-  { host :: HostName,
+type NtfServer = ProtocolServer 'PNTF
+
+pattern NtfServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
+pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
+
+{-# COMPLETE NtfServer #-}
+
+data ProtocolType = PSMP | PNTF
+  deriving (Eq, Ord, Show)
+
+instance StrEncoding ProtocolType where
+  strEncode = \case
+    PSMP -> "smp"
+    PNTF -> "ntf"
+  strP =
+    A.takeTill (== ':') >>= \case
+      "smp" -> pure PSMP
+      "ntf" -> pure PNTF
+      _ -> fail "bad ProtocolType"
+
+data SProtocolType (p :: ProtocolType) where
+  SPSMP :: SProtocolType 'PSMP
+  SPNTF :: SProtocolType 'PNTF
+
+deriving instance Eq (SProtocolType p)
+
+deriving instance Ord (SProtocolType p)
+
+deriving instance Show (SProtocolType p)
+
+data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
+
+instance TestEquality SProtocolType where
+  testEquality SPSMP SPSMP = Just Refl
+  testEquality SPNTF SPNTF = Just Refl
+  testEquality _ _ = Nothing
+
+protocolType :: SProtocolType p -> ProtocolType
+protocolType = \case
+  SPSMP -> PSMP
+  SPNTF -> PNTF
+
+aProtocolType :: ProtocolType -> AProtocolType
+aProtocolType = \case
+  PSMP -> AProtocolType SPSMP
+  PNTF -> AProtocolType SPNTF
+
+instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
+  strEncode = strEncode . protocolType
+  strP = (\(AProtocolType p) -> checkProtocolType p) <$?> strP
+
+instance StrEncoding AProtocolType where
+  strEncode (AProtocolType p) = strEncode p
+  strP = aProtocolType <$> strP
+
+checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
+checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
+  Just Refl -> Right p
+  Nothing -> Left "bad ProtocolType"
+
+class ProtocolTypeI (p :: ProtocolType) where
+  protocolTypeI :: SProtocolType p
+
+instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP
+
+instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
+
+-- | server location and transport key digest (hash).
+data ProtocolServer p = ProtocolServer
+  { scheme :: SProtocolType p,
+    host :: HostName,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
   deriving (Eq, Ord, Show)
 
-instance IsString ProtocolServer where
+instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 
-instance Encoding ProtocolServer where
+instance ProtocolTypeI p => Encoding (ProtocolServer p) where
   smpEncode ProtocolServer {host, port, keyHash} =
     smpEncode (host, port, keyHash)
   smpP = do
     (host, port, keyHash) <- smpP
-    pure ProtocolServer {host, port, keyHash}
+    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}
 
-instance StrEncoding ProtocolServer where
-  strEncode ProtocolServer {host, port, keyHash} =
-    "smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
+instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
+  strEncode ProtocolServer {scheme, host, port, keyHash} =
+    strEncode scheme <> "://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
   strP = do
-    _ <- "smp://"
+    scheme <- strP <* "://"
     keyHash <- strP <* A.char '@'
     SrvLoc host port <- strP
-    pure ProtocolServer {host, port, keyHash}
+    pure ProtocolServer {scheme, host, port, keyHash}
 
-instance ToJSON ProtocolServer where
+instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
@@ -512,6 +717,12 @@ type NtfPrivateSignKey = C.APrivateSignKey
 -- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
 type NtfPublicVerifyKey = C.APublicVerifyKey
 
+-- | Public key used for DH exchange to encrypt notification metadata from server to recipient
+type RcvNtfPublicDhKey = C.PublicKeyX25519
+
+-- | DH Secret used to encrypt notification metadata from server to recipient
+type RcvNtfDhSecret = C.DhSecretX25519
+
 -- | SMP message server ID.
 type MsgId = ByteString
 
@@ -532,7 +743,7 @@ data ErrorType
     QUOTA
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
-  | -- | sent message is too large (> maxMessageLength = 16078 bytes)
+  | -- | sent message is too large (> maxMessageLength = 16088 bytes)
     LARGE_MSG
   | -- | internal server error
     INTERNAL
@@ -588,14 +799,18 @@ transmissionP = do
       command <- A.takeByteString
       pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
 
-class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
-  type ProtocolCommand msg = cmd | cmd -> msg
+class (ProtocolEncoding msg, ProtocolEncoding (ProtoCommand msg), Show msg) => Protocol msg where
+  type ProtoCommand msg = cmd | cmd -> msg
+  type ProtoType msg = (sch :: ProtocolType) | sch -> msg
   protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-  protocolPing :: ProtocolCommand msg
+  protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe ErrorType
 
+type ProtoServer msg = ProtocolServer (ProtoType msg)
+
 instance Protocol BrokerMsg where
-  type ProtocolCommand BrokerMsg = Cmd
+  type ProtoCommand BrokerMsg = Cmd
+  type ProtoType BrokerMsg = 'PSMP
   protocolClientHandshake = smpClientHandshake
   protocolPing = Cmd SSender PING
   protocolError = \case
@@ -614,7 +829,8 @@ instance PartyI p => ProtocolEncoding (Command p) where
     NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
-    NKEY k -> e (NKEY_, ' ', k)
+    NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
+    NDEL -> e NDEL_
     GET -> e GET_
     ACK msgId
       | v == 1 -> e ACK_
@@ -661,7 +877,8 @@ instance ProtocolEncoding Cmd where
         NEW_ -> NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
-        NKEY_ -> NKEY <$> _smpP
+        NKEY_ -> NKEY <$> _smpP <*> smpP
+        NDEL_ -> pure NDEL
         GET_ -> pure GET
         ACK_
           | v == 1 -> pure $ ACK ""
@@ -682,11 +899,12 @@ instance ProtocolEncoding BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol v = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
-    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_
+    MSG RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body}
+      | v == 1 -> e (MSG_, ' ', msgId, msgTs, Tail body)
+      | v == 2 -> e (MSG_, ' ', msgId, msgTs, msgFlags, ' ', Tail body)
+      | otherwise -> e (MSG_, ' ', msgId, Tail body)
+    NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
+    NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
     END -> e END_
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
@@ -696,12 +914,17 @@ instance ProtocolEncoding BrokerMsg where
       e = smpEncode
 
   protocolP v = \case
-    MSG_
-      | v == 1 -> MSG <$> _smpP <*> smpP <*> pure noMsgFlags <*> (unTail <$> smpP)
-      | otherwise -> MSG <$> _smpP <*> smpP <*> smpP <*> (unTail <$> _smpP)
+    MSG_ -> do
+      msgId <- _smpP
+      MSG <$> case v of
+        1 -> RcvMessage msgId <$> smpP <*> pure noMsgFlags <*> bodyP
+        2 -> RcvMessage msgId <$> smpP <*> smpP <*> (A.space *> bodyP)
+        _ -> RcvMessage msgId (MkSystemTime 0 0) noMsgFlags <$> bodyP
+      where
+        bodyP = EncRcvMsgBody . unTail <$> smpP
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
-    NID_ -> NID <$> _smpP
-    NMSG_ -> pure NMSG
+    NID_ -> NID <$> _smpP <*> smpP
+    NMSG_ -> NMSG <$> _smpP <*> smpP
     END_ -> pure END
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP

src/Simplex/Messaging/Server.hs

@@ -40,8 +40,10 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
+import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.List (intercalate)
 import qualified Data.Map.Strict as M
@@ -49,13 +51,17 @@ import Data.Maybe (isNothing)
 import Data.Set (Set)
 import qualified Data.Set as S
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Calendar.Month.Compat (pattern MonthDay)
 import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
+import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding (Encoding (smpEncode))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
@@ -64,12 +70,15 @@ import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
+import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
+import System.Exit (exitFailure)
+import System.IO (hPutStrLn)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
@@ -96,13 +105,14 @@ smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m (
 smpServer started = do
   s <- asks server
   cfg@ServerConfig {transports} <- asks config
+  restoreServerStats
   restoreServerMessages
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
       map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
     )
-    `finally` (withLog closeStoreLog >> saveServerMessages)
+    `finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
   where
     runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
@@ -156,32 +166,34 @@ smpServer started = do
             >>= atomically . (`deleteExpiredMsgs` old)
 
     serverStatsThread_ :: ServerConfig -> [m ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime} =
-      [logServerStats logStatsStartTime interval]
+    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
+      [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> m ()
-    logServerStats startAt logInterval = do
+    logServerStats :: Int -> Int -> FilePath -> m ()
+    logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      logInfo $ "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
+      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
       let interval = 1000000 * logInterval
-      forever $ do
-        ts <- liftIO getCurrentTime
-        fromTime' <- atomically $ swapTVar fromTime ts
-        qCreated' <- atomically $ swapTVar qCreated 0
-        qSecured' <- atomically $ swapTVar qSecured 0
-        qDeleted' <- atomically $ swapTVar qDeleted 0
-        msgSent' <- atomically $ swapTVar msgSent 0
-        msgRecv' <- atomically $ swapTVar msgRecv 0
-        let day = utctDay ts
-            (_, wDay) = mondayStartWeek day
-            MonthDay _ mDay = day
-        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
-          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
-        logInfo . T.pack $ intercalate "," [show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
-        threadDelay interval
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          qCreated' <- atomically $ swapTVar qCreated 0
+          qSecured' <- atomically $ swapTVar qSecured 0
+          qDeleted' <- atomically $ swapTVar qDeleted 0
+          msgSent' <- atomically $ swapTVar msgSent 0
+          msgRecv' <- atomically $ swapTVar msgRecv 0
+          let day = utctDay ts
+              (_, wDay) = mondayStartWeek day
+              MonthDay _ mDay = day
+          (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
+            atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
+          hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayMsgQueues', weekMsgQueues', monthMsgQueues']
+          threadDelay interval
       where
         periodCount :: Int -> TVar (Set RecipientId) -> STM String
         periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
@@ -196,10 +208,10 @@ smpServer started = do
         Left _ -> pure ()
 
 runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
-runClientTransport th@THandle {sessionId} = do
+runClientTransport th@THandle {thVersion, sessionId} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
-  c <- atomically $ newClient q sessionId ts
+  c <- atomically $ newClient q thVersion sessionId ts
   s <- asks server
   expCfg <- asks $ inactiveClientExpiration . config
   raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
@@ -269,7 +281,7 @@ verifyTransmission sig_ signed queueId cmd = do
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
     Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
     Cmd SSender PING -> pure True
-    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
+    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
   where
     verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
     verifyCmd party f = do
@@ -305,7 +317,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
+client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
@@ -327,11 +339,12 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                 (asks $ allowNewQueues . config)
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
-            SUB -> subscribeQueue queueId
-            GET -> getMessage
-            ACK msgId -> acknowledgeMsg msgId
+            SUB -> subscribeQueue st queueId
+            GET -> getMessage st
+            ACK msgId -> acknowledgeMsg st msgId
             KEY sKey -> secureQueue_ st sKey
-            NKEY nKey -> addQueueNotifier_ st nKey
+            NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
+            NDEL -> deleteQueueNotifier_ st
             OFF -> suspendQueue_ st
             DEL -> delQueueAndMsgs st
       where
@@ -365,7 +378,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
                   atomically $ modifyTVar (qCreated stats) (+ 1)
-                  subscribeQueue rId $> IDS (qik ids)
+                  subscribeQueue st rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -385,27 +398,36 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
           atomically $ modifyTVar (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
-        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
-        addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
+        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
+        addQueueNotifier_ st notifierKey dhKey = do
+          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
+          let rcvNtfDhSecret = C.dh' dhKey privDhKey
+          (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
           where
-            addNotifierRetry :: Int -> m BrokerMsg
-            addNotifierRetry 0 = pure $ ERR INTERNAL
-            addNotifierRetry n = do
-              nId <- randomId =<< asks (queueIdBytes . config)
-              atomically (addQueueNotifier st queueId nId nKey) >>= \case
-                Left DUPLICATE_ -> addNotifierRetry $ n - 1
+            addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> m BrokerMsg
+            addNotifierRetry 0 _ _ = pure $ ERR INTERNAL
+            addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
+              notifierId <- randomId =<< asks (queueIdBytes . config)
+              let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
+              atomically (addQueueNotifier st queueId ntfCreds) >>= \case
+                Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
                 Left e -> pure $ ERR e
                 Right _ -> do
-                  withLog $ \s -> logAddNotifier s queueId nId nKey
-                  pure $ NID nId
+                  withLog $ \s -> logAddNotifier s queueId ntfCreds
+                  pure $ NID notifierId rcvPublicDhKey
+
+        deleteQueueNotifier_ :: QueueStore -> m (Transmission BrokerMsg)
+        deleteQueueNotifier_ st = do
+          withLog (`logDeleteNotifier` queueId)
+          okResp <$> atomically (deleteQueueNotifier st queueId)
 
         suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
           withLog (`logDeleteQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        subscribeQueue :: RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue rId =
+        subscribeQueue :: QueueStore -> RecipientId -> m (Transmission BrokerMsg)
+        subscribeQueue st rId =
           atomically (TM.lookup rId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= deliver
@@ -427,10 +449,10 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             deliver sub = do
               q <- getStoreMsgQueue rId
               msg_ <- atomically $ tryPeekMsg q
-              deliverMessage rId sub q msg_
+              deliverMessage st rId sub q msg_
 
-        getMessage :: m (Transmission BrokerMsg)
-        getMessage =
+        getMessage :: QueueStore -> m (Transmission BrokerMsg)
+        getMessage st =
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= getMessage_
@@ -449,13 +471,21 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
               TM.insert queueId sub subscriptions
               pure s
             getMessage_ :: Sub -> m (Transmission BrokerMsg)
-            getMessage_ s = do
+            getMessage_ s = withRcvQueue st queueId $ \qr -> do
               q <- getStoreMsgQueue queueId
               atomically $
                 tryPeekMsg q >>= \case
-                  Just msg -> setDelivered s msg $> (corrId, queueId, msgCmd msg)
+                  Just msg ->
+                    let encMsg = encryptMsg qr msg
+                     in setDelivered s msg $> (corrId, queueId, MSG encMsg)
                   _ -> pure (corrId, queueId, OK)
 
+        withRcvQueue :: QueueStore -> RecipientId -> (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
+        withRcvQueue st rId action =
+          atomically (getQueue st SRecipient rId) >>= \case
+            Left e -> pure (corrId, rId, ERR e)
+            Right qr -> action qr
+
         subscribeNotifications :: m (Transmission BrokerMsg)
         subscribeNotifications = atomically $ do
           unlessM (TM.member queueId ntfSubscriptions) $ do
@@ -463,8 +493,8 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             TM.insert queueId () ntfSubscriptions
           pure ok
 
-        acknowledgeMsg :: MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg msgId = do
+        acknowledgeMsg :: QueueStore -> MsgId -> m (Transmission BrokerMsg)
+        acknowledgeMsg st msgId = do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing -> pure $ err NO_MSG
             Just sub ->
@@ -479,14 +509,14 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                     _ -> do
                       (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
                       when msgDeleted updateStats
-                      deliverMessage queueId sub q msg_
+                      deliverMessage st 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'
+                if msgId == msgId' || B.null msgId
                   then pure $ Just s
                   else putTMVar delivered msgId' $> Nothing
             updateStats :: m ()
@@ -504,7 +534,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
 
         sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage st flags msgBody
+        sendMessage st msgFlags msgBody
           | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
           | otherwise = do
             qr <- atomically $ getQueue st SSender queueId
@@ -514,17 +544,18 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
             storeMessage qr = case status qr of
               QueueOff -> return $ err AUTH
               QueueActive ->
-                mkMessage >>= \case
+                mapM mkMessage (C.maxLenBS msgBody) >>= \case
                   Left _ -> pure $ err LARGE_MSG
                   Right msg -> do
                     ms <- asks msgStore
                     ServerConfig {messageExpiration, msgQueueQuota} <- asks config
                     old <- liftIO $ mapM expireBeforeEpoch messageExpiration
+                    ntfNonceDrg <- asks idsDrg
                     resp@(_, _, sent) <- atomically $ do
                       q <- getMsgQueue ms (recipientId qr) msgQueueQuota
                       mapM_ (deleteExpiredMsgs q) old
                       ifM (isFull q) (pure $ err QUOTA) $ do
-                        when (notification flags) trySendNotification
+                        when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
                         writeMsg q msg
                         pure ok
                     when (sent == OK) $ do
@@ -533,47 +564,66 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
                       atomically $ updateActiveQueues stats $ recipientId qr
                     pure resp
               where
-                mkMessage :: m (Either C.CryptoError Message)
-                mkMessage = do
+                mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
+                mkMessage body = do
                   msgId <- randomId =<< asks (msgIdBytes . config)
-                  ts <- liftIO getSystemTime
-                  let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
-                  pure $ Message msgId ts flags <$> c
+                  msgTs <- liftIO getSystemTime
+                  pure $ Message msgId msgTs msgFlags body
 
-                trySendNotification :: STM ()
-                trySendNotification =
-                  forM_ (notifier qr) $ \(nId, _) ->
-                    mapM_ (writeNtf nId) =<< TM.lookup nId notifiers
+                trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
+                trySendNotification msg ntfNonceDrg =
+                  forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
+                    mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
 
-                writeNtf :: NotifierId -> Client -> STM ()
-                writeNtf nId Client {sndQ = q} =
-                  unlessM (isFullTBQueue sndQ) $
-                    writeTBQueue q (CorrId "", nId, NMSG)
+                writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
+                writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
+                  unlessM (isFullTBQueue sndQ) $ do
+                    (nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
+                    writeTBQueue q (CorrId "", nId, NMSG nmsgNonce encNMsgMeta)
 
-        deliverMessage :: RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage rId sub q msg_ =
+                mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
+                mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
+                  cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
+                  let msgMeta = NMsgMeta {msgId, msgTs}
+                      encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
+                  pure . (cbNonce,) $ fromRight "" encNMsgMeta
+
+        deliverMessage :: QueueStore -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
+        deliverMessage st rId sub q msg_ = withRcvQueue st rId $ \qr -> do
           readTVarIO sub >>= \case
             s@Sub {subThread = NoSub} ->
               case msg_ of
-                Just msg -> atomically (setDelivered s msg) $> (corrId, rId, msgCmd msg)
-                _ -> forkSub $> ok
+                Just msg ->
+                  let encMsg = encryptMsg qr msg
+                   in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
+                _ -> forkSub qr $> ok
             _ -> pure ok
           where
-            forkSub :: m ()
-            forkSub = do
+            forkSub :: QueueRec -> m ()
+            forkSub qr = 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
+              where
+                subscriber = atomically $ do
+                  msg <- peekMsg q
+                  let encMsg = encryptMsg qr msg
+                  writeTBQueue sndQ (CorrId "", rId, MSG encMsg)
+                  s <- readTVar sub
+                  void $ setDelivered s msg
+                  writeTVar sub s {subThread = NoSub}
 
-            subscriber :: m ()
-            subscriber = atomically $ do
-              msg <- peekMsg q
-              writeTBQueue sndQ (CorrId "", rId, msgCmd msg)
-              s <- readTVar sub
-              void $ setDelivered s msg
-              writeTVar sub s {subThread = NoSub}
+        encryptMsg :: QueueRec -> Message -> RcvMessage
+        encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody}
+          | thVersion == 1 || thVersion == 2 = encrypt msgBody
+          | otherwise = encrypt $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
+          where
+            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
+            encrypt body =
+              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId) body
+               in RcvMessage msgId msgTs msgFlags encBody
 
         setDelivered :: Sub -> Message -> STM Bool
         setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
@@ -584,9 +634,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
           quota <- asks $ msgQueueQuota . config
           atomically $ getMsgQueue ms rId quota
 
-        msgCmd :: Message -> BrokerMsg
-        msgCmd Message {msgId, ts, msgFlags, msgBody} = MSG msgId ts msgFlags msgBody
-
         delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
         delQueueAndMsgs st = do
           withLog (`logDeleteQueue` queueId)
@@ -617,33 +664,76 @@ randomId n = do
   gVar <- asks idsDrg
   atomically (C.pseudoRandomBytes n gVar)
 
-saveServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
 saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
   where
     saveMessages f = do
-      liftIO $ putStrLn $ "saving messages to file " <> f
+      logInfo $ "saving messages to file " <> T.pack f
       ms <- asks msgStore
       liftIO . withFile f WriteMode $ \h ->
         readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
+      logInfo "messages saved"
       where
         saveQueueMsgs ms h rId =
           atomically (flushMsgQueue ms rId)
-            >>= mapM_ (B.hPutStrLn h . strEncode . MsgLogRecord rId)
+            >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 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
+      logInfo $ "restoring messages from file " <> T.pack f
+      st <- asks queueStore
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
-      liftIO $ mapM_ (restoreMsg ms quota) . B.lines =<< B.readFile f
-      renameFile f $ f <> ".bak"
+      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
+        Left e -> do
+          logError . T.pack $ "error restoring messages: " <> e
+          liftIO exitFailure
+        _ -> do
+          renameFile f $ f <> ".bak"
+          logInfo "messages restored"
       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)
+        restoreMsg st ms quota s = do
+          r <- liftEither . first (msgErr "parsing") $ strDecode s
+          case r of
+            MLRv3 rId msg -> addToMsgQueue rId msg
+            MLRv1 rId encMsg -> do
+              qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
+              msg' <- updateMsgV1toV3 qr encMsg
+              addToMsgQueue rId msg'
+          where
+            addToMsgQueue rId msg = do
+              full <- atomically $ do
+                q <- getMsgQueue ms rId quota
+                ifM (isFull q) (pure True) (writeMsg q msg $> False)
+              when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
+            updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
+              let nonce = C.cbNonce msgId
+              msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
+              pure Message {msgId, msgTs, msgFlags, msgBody}
+            msgErr :: Show e => String -> e -> String
+            msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
+
+saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
+saveServerStats =
+  asks (serverStatsBackupFile . config)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
+  where
+    saveStats f stats = do
+      logInfo $ "saving server stats to file " <> T.pack f
+      B.writeFile f $ strEncode stats
+      logInfo "server stats saved"
+
+restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+  where
+    restoreStats f = whenM (doesFileExist f) $ do
+      logInfo $ "restoring server stats from file " <> T.pack f
+      liftIO (strDecode <$> B.readFile f) >>= \case
+        Right d -> do
+          s <- asks serverStats
+          atomically $ setServerStatsData s d
+          renameFile f $ f <> ".bak"
+          logInfo "server stats restored"
+        Left e -> logInfo $ "error restoring server stats: " <> T.pack e

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -12,9 +11,7 @@ import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
@@ -24,8 +21,9 @@ import Simplex.Messaging.Crypto (KeyHash (..))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.STM
-import Simplex.Messaging.Server.QueueStore (QueueRec (..))
+import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -57,6 +55,10 @@ data ServerConfig = ServerConfig
     -- | time of the day when the stats are logged first, to log at consistent times,
     -- irrespective of when the server is started (seconds from 00:00 UTC)
     logStatsStartTime :: Int,
+    -- | file to log stats
+    serverStatsLogFile :: FilePath,
+    -- | file to save and restore stats
+    serverStatsBackupFile :: Maybe FilePath,
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -103,23 +105,12 @@ data Client = Client
     ntfSubscriptions :: TMap NotifierId (),
     rcvQ :: TBQueue (Transmission Cmd),
     sndQ :: TBQueue (Transmission BrokerMsg),
+    thVersion :: Version,
     sessionId :: ByteString,
     connected :: TVar Bool,
     activeAt :: TVar SystemTime
   }
 
-data ServerStats = ServerStats
-  { qCreated :: TVar Int,
-    qSecured :: TVar Int,
-    qDeleted :: TVar Int,
-    msgSent :: TVar Int,
-    msgRecv :: TVar Int,
-    dayMsgQueues :: TVar (Set RecipientId),
-    weekMsgQueues :: TVar (Set RecipientId),
-    monthMsgQueues :: TVar (Set RecipientId),
-    fromTime :: TVar UTCTime
-  }
-
 data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
 
 data Sub = Sub
@@ -135,28 +126,15 @@ newServer qSize = do
   notifiers <- TM.empty
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
-newClient :: Natural -> ByteString -> SystemTime -> STM Client
-newClient qSize sessionId ts = do
+newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
+newClient qSize thVersion sessionId ts = do
   subscriptions <- TM.empty
   ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
   activeAt <- newTVar ts
-  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected, activeAt}
-
-newServerStats :: UTCTime -> STM ServerStats
-newServerStats ts = do
-  qCreated <- newTVar 0
-  qSecured <- newTVar 0
-  qDeleted <- newTVar 0
-  msgSent <- newTVar 0
-  msgRecv <- newTVar 0
-  dayMsgQueues <- newTVar S.empty
-  weekMsgQueues <- newTVar S.empty
-  monthMsgQueues <- newTVar S.empty
-  fromTime <- newTVar ts
-  pure ServerStats {qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues, fromTime}
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription subThread = do
@@ -190,4 +168,4 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
     addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
     addNotifier q = case notifier q of
       Nothing -> id
-      Just (nId, _) -> M.insert nId (recipientId q)
+      Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)

src/Simplex/Messaging/Server/MsgStore.hs

@@ -1,32 +1,22 @@
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
+import Control.Applicative ((<|>))
 import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime)
 import Numeric.Natural
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (MsgBody, MsgFlags, MsgId, RecipientId)
+import Simplex.Messaging.Protocol (Message (..), MsgId, RcvMessage (..), 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
+data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
 
 instance StrEncoding MsgLogRecord where
-  strEncode (MsgLogRecord rId msg) = strEncode (rId, msg)
-  strP = MsgLogRecord <$> strP_ <*> strP
+  strEncode = \case
+    MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
+    MLRv1 rId msg -> strEncode (rId, msg)
+  strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
 
 class MonadMsgStore s q m | s -> q where
   getMsgQueue :: s -> RecipientId -> Natural -> m q

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

@@ -11,11 +11,12 @@ module Simplex.Messaging.Server.MsgStore.STM where
 
 import Control.Concurrent.STM.TBQueue (flushTBQueue)
 import Control.Monad (when)
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Numeric.Natural
-import Simplex.Messaging.Protocol (MsgId, RecipientId)
+import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
 import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -60,7 +61,7 @@ instance MonadMsgQueue MsgQueue STM where
   tryDelMsg (MsgQueue q) msgId' =
     tryPeekTBQueue q >>= \case
       Just Message {msgId}
-        | msgId == msgId' -> tryReadTBQueue q $> True
+        | msgId == msgId' || B.null msgId' -> tryReadTBQueue q $> True
         | otherwise -> pure False
       _ -> pure False
 
@@ -69,7 +70,7 @@ instance MonadMsgQueue MsgQueue STM where
   tryDelPeekMsg (MsgQueue q) msgId' =
     tryPeekTBQueue q >>= \case
       msg_@(Just Message {msgId})
-        | msgId == msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
+        | msgId == msgId' || B.null msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
         | otherwise -> pure (False, msg_)
       _ -> pure (False, Nothing)
 
@@ -77,6 +78,6 @@ instance MonadMsgQueue MsgQueue STM where
   deleteExpiredMsgs (MsgQueue q) old = loop
     where
       loop = tryPeekTBQueue q >>= mapM_ delOldMsg
-      delOldMsg Message {ts} =
-        when (systemSeconds ts < old) $
+      delOldMsg Message {msgTs} =
+        when (systemSeconds msgTs < old) $
           tryReadTBQueue q >> loop

src/Simplex/Messaging/Server/QueueStore.hs

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

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

@@ -61,16 +61,23 @@ instance MonadQueueStore QueueStore STM where
         Just _ -> pure Nothing
         _ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
 
-  addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)
-  addQueueNotifier QueueStore {queues, notifiers} rId nId nKey = do
+  addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
+  addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
     ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
-      withQueue rId queues $ \qVar ->
-        readTVar qVar >>= \q -> case notifier q of
-          Just _ -> pure Nothing
-          _ -> do
-            writeTVar qVar q {notifier = Just (nId, nKey)}
-            TM.insert nId rId notifiers
-            pure $ Just q
+      withQueue rId queues $ \qVar -> do
+        q <- readTVar qVar
+        forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
+        writeTVar qVar q {notifier = Just ntfCreds}
+        TM.insert nId rId notifiers
+        pure $ Just q
+
+  deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+  deleteQueueNotifier QueueStore {queues, notifiers} rId =
+    withQueue rId queues $ \qVar -> do
+      q <- readTVar qVar
+      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
+      writeTVar qVar q {notifier = Nothing}
+      pure $ Just ()
 
   suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
   suspendQueue QueueStore {queues} rId =
@@ -82,7 +89,7 @@ instance MonadQueueStore QueueStore STM where
       Just qVar ->
         readTVar qVar >>= \q -> do
           TM.delete (senderId q) senders
-          forM_ (notifier q) $ \(nId, _) -> TM.delete nId notifiers
+          forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
           pure $ Right ()
       _ -> pure $ Left AUTH
 

src/Simplex/Messaging/Server/Stats.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Server.Stats where
+
+import Control.Applicative (optional)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock (UTCTime)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (RecipientId)
+import UnliftIO.STM
+
+data ServerStats = ServerStats
+  { fromTime :: TVar UTCTime,
+    qCreated :: TVar Int,
+    qSecured :: TVar Int,
+    qDeleted :: TVar Int,
+    msgSent :: TVar Int,
+    msgRecv :: TVar Int,
+    dayMsgQueues :: TVar (Set RecipientId),
+    weekMsgQueues :: TVar (Set RecipientId),
+    monthMsgQueues :: TVar (Set RecipientId)
+  }
+
+data ServerStatsData = ServerStatsData
+  { _fromTime :: UTCTime,
+    _qCreated :: Int,
+    _qSecured :: Int,
+    _qDeleted :: Int,
+    _msgSent :: Int,
+    _msgRecv :: Int,
+    _dayMsgQueues :: Set RecipientId,
+    _weekMsgQueues :: Set RecipientId,
+    _monthMsgQueues :: Set RecipientId
+  }
+
+newServerStats :: UTCTime -> STM ServerStats
+newServerStats ts = do
+  fromTime <- newTVar ts
+  qCreated <- newTVar 0
+  qSecured <- newTVar 0
+  qDeleted <- newTVar 0
+  msgSent <- newTVar 0
+  msgRecv <- newTVar 0
+  dayMsgQueues <- newTVar S.empty
+  weekMsgQueues <- newTVar S.empty
+  monthMsgQueues <- newTVar S.empty
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues}
+
+getServerStatsData :: ServerStats -> STM ServerStatsData
+getServerStatsData s = do
+  _fromTime <- readTVar $ fromTime s
+  _qCreated <- readTVar $ qCreated s
+  _qSecured <- readTVar $ qSecured s
+  _qDeleted <- readTVar $ qDeleted s
+  _msgSent <- readTVar $ msgSent s
+  _msgRecv <- readTVar $ msgRecv s
+  _dayMsgQueues <- readTVar $ dayMsgQueues s
+  _weekMsgQueues <- readTVar $ weekMsgQueues s
+  _monthMsgQueues <- readTVar $ monthMsgQueues s
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
+
+setServerStatsData :: ServerStats -> ServerStatsData -> STM ()
+setServerStatsData s d = do
+  writeTVar (fromTime s) (_fromTime d)
+  writeTVar (qCreated s) (_qCreated d)
+  writeTVar (qSecured s) (_qSecured d)
+  writeTVar (qDeleted s) (_qDeleted d)
+  writeTVar (msgSent s) (_msgSent d)
+  writeTVar (msgRecv s) (_msgRecv d)
+  writeTVar (dayMsgQueues s) (_dayMsgQueues d)
+  writeTVar (weekMsgQueues s) (_weekMsgQueues d)
+  writeTVar (monthMsgQueues s) (_monthMsgQueues d)
+
+instance StrEncoding ServerStatsData where
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues} =
+    B.unlines
+      [ "fromTime=" <> strEncode _fromTime,
+        "qCreated=" <> strEncode _qCreated,
+        "qSecured=" <> strEncode _qSecured,
+        "qDeleted=" <> strEncode _qDeleted,
+        "msgSent=" <> strEncode _msgSent,
+        "msgRecv=" <> strEncode _msgRecv,
+        "dayMsgQueues=" <> strEncode _dayMsgQueues,
+        "weekMsgQueues=" <> strEncode _weekMsgQueues,
+        "monthMsgQueues=" <> strEncode _monthMsgQueues
+      ]
+  strP = do
+    _fromTime <- "fromTime=" *> strP <* A.endOfLine
+    _qCreated <- "qCreated=" *> strP <* A.endOfLine
+    _qSecured <- "qSecured=" *> strP <* A.endOfLine
+    _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
+    _msgSent <- "msgSent=" *> strP <* A.endOfLine
+    _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
+    _dayMsgQueues <- "dayMsgQueues=" *> strP <* A.endOfLine
+    _weekMsgQueues <- "weekMsgQueues=" *> strP <* A.endOfLine
+    _monthMsgQueues <- "monthMsgQueues=" *> strP <* optional A.endOfLine
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}

src/Simplex/Messaging/Server/StoreLog.hs

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

src/Simplex/Messaging/Transport.hs

@@ -46,12 +46,15 @@ module Simplex.Messaging.Transport
     -- * SMP transport
     THandle (..),
     TransportError (..),
+    HandshakeError (..),
     smpServerHandshake,
     smpClientHandshake,
     tPutBlock,
     tGetBlock,
     serializeTransportError,
     transportErrorP,
+    sendHandshake,
+    getHandshake,
 
     -- * Trim trailing CR
     trimCR,
@@ -93,10 +96,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 2
+supportedSMPServerVRange = mkVersionRange 1 3
 
 simplexMQVersion :: String
-simplexMQVersion = "2.3.1"
+simplexMQVersion = "3.0.1"
 
 -- * Transport connection class
 

src/Simplex/Messaging/Transport/Client.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Client
@@ -84,7 +83,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_,
     x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
       where
         hooks = XV.defaultHooks
-        checks = XV.defaultChecks
+        checks = XV.defaultChecks {XV.checkFQHN = False}
         certStore = XS.makeCertificateStore sc
         cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
         serviceID = (host, port)

src/Simplex/Messaging/Transport/Server.hs

@@ -54,7 +54,7 @@ runTCPServer started port server = do
     (closeServer started clients)
     $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
       -- catchAll_ is needed here in case the connection was closed earlier
-      cId <- atomically $ stateTVar clientId $ \cId -> (cId + 1, cId + 1)
+      cId <- atomically $ stateTVar clientId $ \cId -> let cId' = cId + 1 in (cId', cId')
       let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
       atomically $ TM.insert cId tId clients

src/Simplex/Messaging/Util.hs

@@ -10,6 +10,8 @@ import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Text (Text)
+import qualified Data.Text as T
 import UnliftIO.Async
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -32,6 +34,10 @@ bshow :: Show a => a -> ByteString
 bshow = B.pack . show
 {-# INLINE bshow #-}
 
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+{-# INLINE tshow #-}
+
 maybeWord :: (a -> ByteString) -> Maybe a -> ByteString
 maybeWord f = maybe "" $ B.cons ' ' . f
 {-# INLINE maybeWord #-}
@@ -56,6 +62,10 @@ tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
 tryE m = (Right <$> m) `catchE` (pure . Left)
 {-# INLINE tryE #-}
 
+liftE :: (e -> e') -> ExceptT e IO a -> ExceptT e' IO a
+liftE f a = ExceptT $ first f <$> runExceptT a
+{-# INLINE liftE #-}
+
 ifM :: Monad m => m Bool -> m a -> m a -> m a
 ifM ba t f = ba >>= \b -> if b then t else f
 {-# INLINE ifM #-}

stack.yaml

@@ -38,7 +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.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987 # below dependancies are to update Aeson to 2.0.3
+  - tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
+  # below dependancies are to update Aeson to 2.0.3
   - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
   - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
   - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005

tests/AgentTests.hs

@@ -325,11 +325,11 @@ 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 4)
+        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
+        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
         bob <# ("", "", UP server ["alice"])
         bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
         bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
-        alice <# ("", "", UP server ["bob"])
         alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
         alice <# ("", "bob", SENT 5)
         bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False

tests/AgentTests/ConnectionRequestTests.hs

@@ -19,12 +19,7 @@ uri :: String
 uri = "smp.simplex.im"
 
 srv :: SMPServer
-srv =
-  ProtocolServer
-    { host = "smp.simplex.im",
-      port = "5223",
-      keyHash = C.KeyHash "\215m\248\251"
-    }
+srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
 
 queue :: SMPQueueUri
 queue =

tests/AgentTests/FunctionalAPITests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -8,6 +9,7 @@
 
 module AgentTests.FunctionalAPITests
   ( functionalAPITests,
+    makeConnection,
     get,
     (##>),
     (=##>),
@@ -24,6 +26,7 @@ import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpSe
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
@@ -45,8 +48,11 @@ get c = atomically (readTBQueue $ subQ c)
 pattern Msg :: MsgBody -> ACommand 'Agent
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
+smpCfgV1 :: ProtocolClientConfig
+smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = mkVersionRange 1 1}
+
 agentCfgV1 :: AgentConfig
-agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1}
+agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
@@ -89,6 +95,13 @@ functionalAPITests t = do
       testInactiveClientDisconnected t
     it "should NOT disconnect active clients" $
       testActiveClientNotDisconnected t
+  describe "Suspending agent" $ do
+    it "should update client when agent is suspended" $
+      withSmpServer t testSuspendingAgent
+    it "should complete sending messages when agent is suspended" $
+      testSuspendingAgentCompleteSending t
+    it "should suspend agent on timeout, even if pending messages not sent" $
+      testSuspendingAgentTimeout t
 
 testAgentClient :: IO ()
 testAgentClient = do
@@ -321,18 +334,11 @@ 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)
+    Right (aliceId, bobId) <- runExceptT $ makeConnection alice bob
+    Right () <- runExceptT $ do
       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
@@ -372,6 +378,17 @@ testDuplicateMessage t = do
       get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
     pure ()
 
+makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
+makeConnection alice bob = 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)
+  pure (aliceId, bobId)
+
 testInactiveClientDisconnected :: ATransport -> IO ()
 testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
@@ -410,6 +427,82 @@ testActiveClientNotDisconnected t = do
           get alice ##> ("", "", DOWN testSMPServer [connId])
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
+testSuspendingAgent :: IO ()
+testSuspendingAgent = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    4 <- sendMessage a bId SMP.noMsgFlags "hello"
+    get a ##> ("", bId, SENT 4)
+    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+    ackMessage b aId 4
+    suspendAgent b 1000000
+    get b ##> ("", "", SUSPENDED)
+    5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
+    get a ##> ("", bId, SENT 5)
+    Nothing <- 100000 `timeout` get b
+    activateAgent b
+    get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
+  pure ()
+
+testSuspendingAgentCompleteSending :: ATransport -> IO ()
+testSuspendingAgentCompleteSending t = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    4 <- sendMessage a bId SMP.noMsgFlags "hello"
+    get a ##> ("", bId, SENT 4)
+    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+    ackMessage b aId 4
+    pure (aId, bId)
+
+  Right () <- runExceptT $ do
+    ("", "", DOWN {}) <- get a
+    ("", "", DOWN {}) <- get b
+    5 <- sendMessage b aId SMP.noMsgFlags "hello too"
+    6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
+    liftIO $ threadDelay 100000
+    suspendAgent b 5000000
+
+  Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
+    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
+    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
+    get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
+    ("", "", SUSPENDED) <- get b
+
+    ("", "", UP {}) <- get a
+    get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
+    ackMessage a bId 5
+    get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
+    ackMessage a bId 6
+
+  pure ()
+
+testSuspendingAgentTimeout :: ATransport -> IO ()
+testSuspendingAgentTimeout t = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aId, _) <- withSmpServer t . runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    4 <- sendMessage a bId SMP.noMsgFlags "hello"
+    get a ##> ("", bId, SENT 4)
+    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+    ackMessage b aId 4
+    pure (aId, bId)
+
+  Right () <- runExceptT $ do
+    ("", "", DOWN {}) <- get a
+    ("", "", DOWN {}) <- get b
+    5 <- sendMessage b aId SMP.noMsgFlags "hello too"
+    6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
+    suspendAgent b 100000
+    ("", "", SUSPENDED) <- get b
+    pure ()
+
+  pure ()
+
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings alice bobId bob aliceId = do
   4 <- sendMessage alice bobId SMP.noMsgFlags "hello"

tests/AgentTests/NotificationTests.hs

@@ -9,35 +9,43 @@ module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
 
-import AgentTests.FunctionalAPITests (get, (##>), (=##>), pattern Msg)
-import Control.Concurrent (threadDelay)
+import AgentTests.FunctionalAPITests (get, makeConnection, (##>), (=##>), pattern Msg)
+import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
-import Data.Bifunctor (bimap)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
-import SMPClient (withSmpServer)
+import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent
+import Simplex.Messaging.Agent.Client (AgentClient)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Protocol (ErrorType (AUTH))
+import Simplex.Messaging.Notifications.Types (NtfToken (..))
+import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Util (tryE)
-import System.Directory (removeFile)
+import System.Directory (doesFileExist, removeFile)
 import Test.Hspec
 import UnliftIO
 
+removeFileIfExists :: FilePath -> IO ()
+removeFileIfExists filePath = do
+  fileExists <- doesFileExist filePath
+  when fileExists $ removeFile filePath
+
 notificationTests :: ATransport -> Spec
 notificationTests t =
-  after_ (removeFile testDB) $ do
+  after_ (removeFile testDB >> removeFileIfExists testDB2) $ do
     describe "Managing notification tokens" $ do
       it "should register and verify notification token" $
         withAPNSMockServer $ \apns ->
@@ -60,20 +68,36 @@ notificationTests t =
         withSmpServer t $
           withAPNSMockServer $ \apns ->
             withNtfServer t $ testNotificationSubscriptionNewConnection apns
+      it "should change notifications mode" $ \_ ->
+        withSmpServer t $
+          withAPNSMockServer $ \apns ->
+            withNtfServer t $ testChangeNotificationsMode apns
+      it "should change token" $ \_ ->
+        withSmpServer t $
+          withAPNSMockServer $ \apns ->
+            withNtfServer t $ testChangeToken apns
+    describe "Notifications server store log" $
+      it "should save and restore tokens and subscriptions" $ \_ ->
+        withSmpServer t $
+          withAPNSMockServer $ \apns ->
+            testNotificationsStoreLog t apns
+    describe "Notifications after SMP server restart" $
+      it "should resume subscriptions after SMP server is restarted" $ \_ ->
+        withAPNSMockServer $ \apns ->
+          withNtfServer t $ testNotificationsSMPRestart t apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
   Right () <- runExceptT $ do
-    let tkn = DeviceToken PPApns "abcd"
-    NTRegistered <- registerNtfToken a tkn
+    let tkn = DeviceToken PPApnsTest "abcd"
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken a tkn verification nonce
-    enableNtfCron a tkn 30
+    verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
     deleteNtfToken a tkn
     -- agent deleted this token
@@ -95,22 +119,21 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
   Right () <- runExceptT $ do
-    let tkn = DeviceToken PPApns "abcd"
-    NTRegistered <- registerNtfToken a tkn
+    let tkn = DeviceToken PPApnsTest "abcd"
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    NTRegistered <- registerNtfToken a tkn
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     _ <- ntfData' .-> "verification"
     _ <- C.cbNonce <$> ntfData' .-> "nonce"
     liftIO $ sendApnsResponse' APNSRespOk
     -- can still use the first verification code, it is the same after decryption
-    verifyNtfToken a tkn verification nonce
-    enableNtfCron a tkn 30
+    verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
     pure ()
   pure ()
@@ -122,16 +145,16 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
   a' <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    let tkn = DeviceToken PPApns "abcd"
-    NTRegistered <- registerNtfToken a tkn
+    let tkn = DeviceToken PPApnsTest "abcd"
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken a tkn verification nonce
+    verifyNtfToken a tkn nonce verification
 
-    NTRegistered <- registerNtfToken a' tkn
+    NTRegistered <- registerNtfToken a' tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     verification' <- ntfData' .-> "verification"
@@ -142,25 +165,22 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     NTActive <- checkNtfToken a tkn
     -- and the second is not yet verified
     liftIO $ threadDelay 50000
-    r <- checkNtfToken a' tkn
-    liftIO . print $ "checkNtfToken a' tkn: " <> show r
-    unless (r == NTConfirmed) $ error "bad status"
+    NTConfirmed <- checkNtfToken a' tkn
     -- now the second token registration is verified
-    verifyNtfToken a' tkn verification' nonce'
+    verifyNtfToken a' tkn nonce' verification'
     -- the first registration is removed
     Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
     -- and the second is active
     NTActive <- checkNtfToken a' tkn
-    enableNtfCron a' tkn 30
     pure ()
   pure ()
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  let tkn = DeviceToken PPApns "abcd"
+  let tkn = DeviceToken PPApnsTest "abcd"
   Right ntfData <- withNtfServer t . runExceptT $ do
-    NTRegistered <- registerNtfToken a tkn
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     liftIO $ sendApnsResponse APNSRespOk
@@ -174,22 +194,22 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   Right () <- withNtfServer t . runExceptT $ do
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn verification nonce
+    Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     verification' <- ntfData' .-> "verification"
     nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
     liftIO $ sendApnsResponse' APNSRespOk
-    verifyNtfToken a' tkn verification' nonce'
+    verifyNtfToken a' tkn nonce' verification'
     NTActive <- checkNtfToken a' tkn
-    enableNtfCron a' tkn 30
+    pure ()
   pure ()
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  Right () <- runExceptT $ do
+  Right (bobId, aliceId, nonce, message) <- runExceptT $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
@@ -199,26 +219,43 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token
-    let tkn = DeviceToken PPApns "abcd"
-    NTRegistered <- registerNtfToken alice tkn
+    let tkn = DeviceToken PPApnsTest "abcd"
+    NTRegistered <- registerNtfToken alice tkn NMInstant
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
-    nonce <- C.cbNonce <$> ntfData .-> "nonce"
+    vNonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    verifyNtfToken alice tkn verification nonce
+    verifyNtfToken alice tkn vNonce verification
     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
+    -- notification
+    (nonce, message) <- messageNotification apnsQ
+    pure (bobId, aliceId, nonce, message)
+
+  -- alice client already has subscription for the connection
+  Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
+
+  -- aliceNtf client doesn't have subscription and is allowed to get notification message
+  aliceNtf <- getSMPAgentClient agentCfg initAgentServers
+  Right () <- runExceptT $ do
+    (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
+    pure ()
+  disconnectAgentClient aliceNtf
+
+  Right () <- runExceptT $ do
     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"
+    -- delete notification subscription
+    deleteNtfSub alice bobId
+    -- send message
+    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+    get bob ##> ("", aliceId, SENT $ baseId + 2)
+    -- no notifications should follow
+    noNotification apnsQ
   pure ()
   where
     baseId = 3
@@ -230,67 +267,249 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
   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
+    _ <- registerTestToken alice "abcd" NMInstant apnsQ
     -- 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
+    _ <- registerTestToken bob "bcde" NMInstant apnsQ
     -- establish connection
     liftIO $ threadDelay 50000
     (bobId, qInfo) <- createConnection alice SCMInvitation
     liftIO $ threadDelay 500000
     aliceId <- joinConnection bob qInfo "bob's connInfo"
-    messageNotification apnsQ
+    liftIO $ print 0
+    void $ messageNotification apnsQ
     ("", _, CONF confId "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    messageNotification apnsQ
+    liftIO $ print 1
+    void $ messageNotification apnsQ
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    messageNotification apnsQ
+    liftIO $ print 2
+    void $ messageNotification apnsQ
     get alice ##> ("", bobId, CON)
-    messageNotification apnsQ
+    liftIO $ print 3
+    void $ 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
+    liftIO $ print 4
+    void $ 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
+    liftIO $ print 5
+    void $ 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"
+    noNotification apnsQ
   pure ()
   where
     baseId = 3
     msgId = subtract baseId
 
-messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
+registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
+registerTestToken a token mode apnsQ = do
+  let tkn = DeviceToken PPApnsTest token
+  NTRegistered <- registerNtfToken a tkn mode
+  APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
+    atomically $ readTBQueue apnsQ
+  verification' <- ntfData' .-> "verification"
+  nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
+  liftIO $ sendApnsResponse' APNSRespOk
+  verifyNtfToken a tkn nonce' verification'
+  NTActive <- checkNtfToken a tkn
+  pure tkn
+
+testChangeNotificationsMode :: APNSMockServer -> IO ()
+testChangeNotificationsMode APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {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, set mode to NMInstant
+    tkn <- registerTestToken alice "abcd" NMInstant apnsQ
+    -- send message, receive notification
+    liftIO $ threadDelay 500000
+    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT $ baseId + 1)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 1
+    -- set mode to NMPeriodic
+    NTActive <- registerNtfToken alice tkn NMPeriodic
+    -- send message, no notification
+    liftIO $ threadDelay 500000
+    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+    get bob ##> ("", aliceId, SENT $ baseId + 2)
+    noNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 2
+    -- set mode to NMInstant
+    NTActive <- registerNtfToken alice tkn NMInstant
+    -- send message, receive notification
+    liftIO $ threadDelay 500000
+    3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 3
+    -- turn off notifications
+    deleteNtfToken alice tkn
+    -- send message, no notification
+    liftIO $ threadDelay 500000
+    4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
+    noNotification apnsQ
+    get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 4
+    -- turn on notifications, set mode to NMInstant
+    void $ registerTestToken alice "abcd" NMInstant apnsQ
+    -- send message, receive notification
+    liftIO $ threadDelay 500000
+    5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
+    get bob ##> ("", aliceId, SENT $ baseId + 5)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 5
+    -- no notifications should follow
+    noNotification apnsQ
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testChangeToken :: APNSMockServer -> IO ()
+testChangeToken APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aliceId, bobId) <- 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, set mode to NMInstant
+    void $ registerTestToken alice "abcd" NMInstant apnsQ
+    -- send message, receive notification
+    liftIO $ threadDelay 500000
+    1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT $ baseId + 1)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 1
+    pure (aliceId, bobId)
+  disconnectAgentClient alice
+
+  alice1 <- getSMPAgentClient agentCfg initAgentServers
+  Right () <- runExceptT $ do
+    subscribeConnection alice1 bobId
+    -- change notification token
+    void $ registerTestToken alice1 "bcde" NMInstant apnsQ
+    -- send message, receive notification
+    liftIO $ threadDelay 500000
+    2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
+    get bob ##> ("", aliceId, SENT $ baseId + 2)
+    void $ messageNotification apnsQ
+    get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
+    ackMessage alice1 bobId $ baseId + 2
+    -- no notifications should follow
+    noNotification apnsQ
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
+testNotificationsStoreLog t APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
+    (aliceId, bobId) <- makeConnection alice bob
+    _ <- registerTestToken alice "abcd" NMInstant apnsQ
+    liftIO $ threadDelay 250000
+    4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT 4)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId 4
+    liftIO $ killThread threadId
+    pure (aliceId, bobId)
+
+  liftIO $ threadDelay 250000
+
+  Right () <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
+    liftIO $ threadDelay 250000
+    5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+    get bob ##> ("", aliceId, SENT 5)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+    liftIO $ killThread threadId
+  pure ()
+
+testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
+testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+    (aliceId, bobId) <- makeConnection alice bob
+    _ <- registerTestToken alice "abcd" NMInstant apnsQ
+    liftIO $ threadDelay 250000
+    4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT 4)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId 4
+    liftIO $ killThread threadId
+    pure (aliceId, bobId)
+
+  Right () <- runExceptT $ do
+    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+
+  Right () <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+    get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
+    get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
+    liftIO $ threadDelay 1000000
+    5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+    get bob ##> ("", aliceId, SENT 5)
+    _ <- messageNotificationData alice apnsQ
+    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+    liftIO $ killThread threadId
+  pure ()
+
+messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apnsQ = do
-  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+  1000000 `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"
+      nonce <- C.cbNonce <$> ntfData .-> "nonce"
+      message <- ntfData .-> "message"
       liftIO $ sendApnsResponse APNSRespOk
+      pure (nonce, message)
     _ -> error "bad notification"
+
+messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
+messageNotificationData c apnsQ = do
+  (nonce, message) <- messageNotification apnsQ
+  NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
+  Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
+  pure pnMsgData
+
+noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
+noNotification apnsQ = do
+  500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+    Nothing -> pure ()
+    _ -> error "unexpected notification"

tests/AgentTests/SQLiteTests.hs

@@ -11,7 +11,6 @@ module AgentTests.SQLiteTests (storeTests) where
 import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Monad (replicateM_)
-import Control.Monad.Except (ExceptT, runExceptT)
 import Crypto.Random (drgNew)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.Text as T
@@ -55,29 +54,23 @@ createStore = do
   createSQLiteStore (testDB <> show r) Migrations.app True
 
 removeStore :: SQLiteStore -> IO ()
-removeStore store = do
-  close store
-  removeFile $ dbFilePath store
+removeStore db = do
+  close db
+  removeFile $ dbFilePath db
   where
     close :: SQLiteStore -> IO ()
     close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
 
-returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation
-action `returnsResult` r = runExceptT action `shouldReturn` Right r
-
-throwsError :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> e -> Expectation
-action `throwsError` e = runExceptT action `shouldReturn` Left e
-
 -- TODO add null port tests
 storeTests :: Spec
 storeTests = do
   withStore2 $ do
     describe "stress test" testConcurrentWrites
   withStore $ do
-    describe "store setup" $ do
+    describe "db setup" $ do
       testCompiledThreadsafe
       testForeignKeysEnabled
-    describe "store methods" $ do
+    describe "db methods" $ do
       describe "Queue and Connection management" $ do
         describe "createRcvConn" $ do
           testCreateRcvConn
@@ -112,28 +105,29 @@ testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
 testConcurrentWrites =
   it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn s1 g cData1 rcvQueue1 SCMInvitation
+    _ <- withTransaction s1 $ \db ->
+      createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let ConnData {connId} = cData1
     concurrently_ (runTest s1 connId) (runTest s2 connId)
   where
-    runTest :: SQLiteStore -> ConnId -> IO (Either StoreError ())
-    runTest store connId = runExceptT . replicateM_ 100 $ do
-      (internalId, internalRcvId, _, _) <- updateRcvIds store connId
+    runTest :: SQLiteStore -> ConnId -> IO ()
+    runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
+      (internalId, internalRcvId, _, _) <- updateRcvIds db connId
       let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
-      createRcvMsg store connId rcvMsgData
+      createRcvMsg db connId rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
 testCompiledThreadsafe =
-  it "compiled sqlite library should be threadsafe" . withStoreConnection $ \db -> do
+  it "compiled sqlite library should be threadsafe" . withStoreTransaction $ \db -> do
     compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[T.Text]]
     compileOptions `shouldNotContain` [["THREADSAFE=0"]]
 
-withStoreConnection :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
-withStoreConnection = flip withConnection
+withStoreTransaction :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
+withStoreTransaction = flip withTransaction
 
 testForeignKeysEnabled :: SpecWith SQLiteStore
 testForeignKeysEnabled =
-  it "foreign keys should be enabled" . withStoreConnection $ \db -> do
+  it "foreign keys should be enabled" . withStoreTransaction $ \db -> do
     let inconsistentQuery =
           [sql|
             INSERT INTO snd_queues
@@ -167,9 +161,7 @@ rcvQueue1 =
       e2eDhSecret = Nothing,
       sndId = Just "2345",
       status = New,
-      ntfPublicKey = Nothing,
-      ntfPrivateKey = Nothing,
-      notifierId = Nothing
+      clientNtfCreds = Nothing
     }
 
 sndQueue1 :: SndQueue
@@ -186,125 +178,125 @@ sndQueue1 =
 
 testCreateRcvConn :: SpecWith SQLiteStore
 testCreateRcvConn =
-  it "should create RcvConnection and add SndQueue" $ \store -> do
+  it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    createRcvConn store g cData1 rcvQueue1 SCMInvitation
-      `returnsResult` "conn1"
-    getConn store "conn1"
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
-    upgradeRcvConnToDuplex store "conn1" sndQueue1
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
+    createRcvConn db g cData1 rcvQueue1 SCMInvitation
+      `shouldReturn` Right "conn1"
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    upgradeRcvConnToDuplex db "conn1" sndQueue1
+      `shouldReturn` Right ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
-  it "should create RcvConnection and add SndQueue with random ID" $ \store -> do
+  it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    Right connId <- runExceptT $ createRcvConn store g cData1 {connId = ""} rcvQueue1 SCMInvitation
-    getConn store connId
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1)
-    upgradeRcvConnToDuplex store connId sndQueue1
-      `returnsResult` ()
-    getConn store connId
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
+    Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
+    getConn db connId
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1))
+    upgradeRcvConnToDuplex db connId sndQueue1
+      `shouldReturn` Right ()
+    getConn db connId
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
 
 testCreateRcvConnDuplicate :: SpecWith SQLiteStore
 testCreateRcvConnDuplicate =
-  it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do
+  it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    createRcvConn store g cData1 rcvQueue1 SCMInvitation
-      `throwsError` SEConnDuplicate
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    createRcvConn db g cData1 rcvQueue1 SCMInvitation
+      `shouldReturn` Left (SEConnDuplicate)
 
 testCreateSndConn :: SpecWith SQLiteStore
 testCreateSndConn =
-  it "should create SndConnection and add RcvQueue" $ \store -> do
+  it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    createSndConn store g cData1 sndQueue1
-      `returnsResult` "conn1"
-    getConn store "conn1"
-      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
-    upgradeSndConnToDuplex store "conn1" rcvQueue1
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
+    createSndConn db g cData1 sndQueue1
+      `shouldReturn` Right "conn1"
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+    upgradeSndConnToDuplex db "conn1" rcvQueue1
+      `shouldReturn` Right ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
-  it "should create SndConnection and add RcvQueue with random ID" $ \store -> do
+  it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    Right connId <- runExceptT $ createSndConn store g cData1 {connId = ""} sndQueue1
-    getConn store connId
-      `returnsResult` SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1)
-    upgradeSndConnToDuplex store connId rcvQueue1
-      `returnsResult` ()
-    getConn store connId
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
+    Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
+    getConn db connId
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1))
+    upgradeSndConnToDuplex db connId rcvQueue1
+      `shouldReturn` Right ()
+    getConn db connId
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
 
 testCreateSndConnDuplicate :: SpecWith SQLiteStore
 testCreateSndConnDuplicate =
-  it "should throw error on attempt to create duplicate SndConnection" $ \store -> do
+  it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
-    createSndConn store g cData1 sndQueue1
-      `throwsError` SEConnDuplicate
+    _ <- createSndConn db g cData1 sndQueue1
+    createSndConn db g cData1 sndQueue1
+      `shouldReturn` Left (SEConnDuplicate)
 
 testGetRcvConn :: SpecWith SQLiteStore
 testGetRcvConn =
-  it "should get connection using rcv queue id and server" $ \store -> do
+  it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do
     let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash
     let recipientId = "1234"
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    getRcvConn store smpServer recipientId
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    getRcvConn db smpServer recipientId
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
-  it "should create RcvConnection and delete it" $ \store -> do
+  it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    getConn store "conn1"
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
-    deleteConn store "conn1"
-      `returnsResult` ()
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    deleteConn db "conn1"
+      `shouldReturn` ()
     -- TODO check queues are deleted as well
-    getConn store "conn1"
-      `throwsError` SEConnNotFound
+    getConn db "conn1"
+      `shouldReturn` Left (SEConnNotFound)
 
 testDeleteSndConn :: SpecWith SQLiteStore
 testDeleteSndConn =
-  it "should create SndConnection and delete it" $ \store -> do
+  it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
-    getConn store "conn1"
-      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
-    deleteConn store "conn1"
-      `returnsResult` ()
+    _ <- createSndConn db g cData1 sndQueue1
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+    deleteConn db "conn1"
+      `shouldReturn` ()
     -- TODO check queues are deleted as well
-    getConn store "conn1"
-      `throwsError` SEConnNotFound
+    getConn db "conn1"
+      `shouldReturn` Left (SEConnNotFound)
 
 testDeleteDuplexConn :: SpecWith SQLiteStore
 testDeleteDuplexConn =
-  it "should create DuplexConnection and delete it" $ \store -> do
+  it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
-    deleteConn store "conn1"
-      `returnsResult` ()
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+    deleteConn db "conn1"
+      `shouldReturn` ()
     -- TODO check queues are deleted as well
-    getConn store "conn1"
-      `throwsError` SEConnNotFound
+    getConn db "conn1"
+      `shouldReturn` Left (SEConnNotFound)
 
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
 testUpgradeRcvConnToDuplex =
-  it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do
+  it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
+    _ <- createSndConn db g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
             { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
@@ -315,17 +307,17 @@ testUpgradeRcvConnToDuplex =
               e2eDhSecret = testDhSecret,
               status = New
             }
-    upgradeRcvConnToDuplex store "conn1" anotherSndQueue
-      `throwsError` SEBadConnType CSnd
-    _ <- runExceptT $ upgradeSndConnToDuplex store "conn1" rcvQueue1
-    upgradeRcvConnToDuplex store "conn1" anotherSndQueue
-      `throwsError` SEBadConnType CDuplex
+    upgradeRcvConnToDuplex db "conn1" anotherSndQueue
+      `shouldReturn` Left (SEBadConnType CSnd)
+    _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
+    upgradeRcvConnToDuplex db "conn1" anotherSndQueue
+      `shouldReturn` Left (SEBadConnType CDuplex)
 
 testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
 testUpgradeSndConnToDuplex =
-  it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do
+  it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
             { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
@@ -336,56 +328,54 @@ testUpgradeSndConnToDuplex =
               e2eDhSecret = Nothing,
               sndId = Just "4567",
               status = New,
-              ntfPublicKey = Nothing,
-              ntfPrivateKey = Nothing,
-              notifierId = Nothing
+              clientNtfCreds = Nothing
             }
-    upgradeSndConnToDuplex store "conn1" anotherRcvQueue
-      `throwsError` SEBadConnType CRcv
-    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
-    upgradeSndConnToDuplex store "conn1" anotherRcvQueue
-      `throwsError` SEBadConnType CDuplex
+    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
+      `shouldReturn` Left (SEBadConnType CRcv)
+    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
+      `shouldReturn` Left (SEBadConnType CDuplex)
 
 testSetRcvQueueStatus :: SpecWith SQLiteStore
 testSetRcvQueueStatus =
-  it "should update status of RcvQueue" $ \store -> do
+  it "should update status of RcvQueue" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    getConn store "conn1"
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
-    setRcvQueueStatus store rcvQueue1 Confirmed
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed})
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    setRcvQueueStatus db rcvQueue1 Confirmed
+      `shouldReturn` ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed}))
 
 testSetSndQueueStatus :: SpecWith SQLiteStore
 testSetSndQueueStatus =
-  it "should update status of SndQueue" $ \store -> do
+  it "should update status of SndQueue" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
-    getConn store "conn1"
-      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
-    setSndQueueStatus store sndQueue1 Confirmed
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed})
+    _ <- createSndConn db g cData1 sndQueue1
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+    setSndQueueStatus db sndQueue1 Confirmed
+      `shouldReturn` ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed}))
 
 testSetQueueStatusDuplex :: SpecWith SQLiteStore
 testSetQueueStatusDuplex =
-  it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do
+  it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
-    setRcvQueueStatus store rcvQueue1 Secured
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1)
-    setSndQueueStatus store sndQueue1 Confirmed
-      `returnsResult` ()
-    getConn store "conn1"
-      `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed})
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+    setRcvQueueStatus db rcvQueue1 Secured
+      `shouldReturn` ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1))
+    setSndQueueStatus db sndQueue1 Confirmed
+      `shouldReturn` ()
+    getConn db "conn1"
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}))
 
 hw :: ByteString
 hw = encodeUtf8 "Hello world!"
@@ -411,22 +401,24 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
       externalPrevSndHash = "hash_from_sender"
     }
 
-testCreateRcvMsg_ :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
-testCreateRcvMsg_ st expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
+testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
+testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
   let MsgMeta {recipient = (internalId, _)} = msgMeta
-  updateRcvIds st connId
-    `returnsResult` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
-  createRcvMsg st connId rcvMsgData
-    `returnsResult` ()
+  updateRcvIds db connId
+    `shouldReturn` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
+  createRcvMsg db connId rcvMsgData
+    `shouldReturn` ()
 
 testCreateRcvMsg :: SpecWith SQLiteStore
 testCreateRcvMsg =
   it "should reserve internal ids and create a RcvMsg" $ \st -> do
     g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    _ <- runExceptT $ createRcvConn st g cData1 rcvQueue1 SCMInvitation
-    testCreateRcvMsg_ st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
-    testCreateRcvMsg_ st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
+    _ <- withTransaction st $ \db -> do
+      createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    withTransaction st $ \db -> do
+      testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
+      testCreateRcvMsg_ db 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
 
 mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
 mkSndMsgData internalId internalSndId internalHash =
@@ -441,32 +433,36 @@ mkSndMsgData internalId internalSndId internalHash =
       prevMsgHash = internalHash
     }
 
-testCreateSndMsg_ :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
-testCreateSndMsg_ store expectedPrevHash connId sndMsgData@SndMsgData {..} = do
-  updateSndIds store connId
-    `returnsResult` (internalId, internalSndId, expectedPrevHash)
-  createSndMsg store connId sndMsgData
-    `returnsResult` ()
+testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
+testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do
+  updateSndIds db connId
+    `shouldReturn` (internalId, internalSndId, expectedPrevHash)
+  createSndMsg db connId sndMsgData
+    `shouldReturn` ()
 
 testCreateSndMsg :: SpecWith SQLiteStore
 testCreateSndMsg =
-  it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \store -> do
+  it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do
     g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    _ <- runExceptT $ createSndConn store g cData1 sndQueue1
-    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
-    testCreateSndMsg_ store "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
+    _ <- withTransaction st $ \db -> do
+      createSndConn db g cData1 sndQueue1
+    withTransaction st $ \db -> do
+      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
+      testCreateSndMsg_ db "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
 
 testCreateRcvAndSndMsgs :: SpecWith SQLiteStore
 testCreateRcvAndSndMsgs =
-  it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do
-    g <- newTVarIO =<< drgNew
+  it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do
     let ConnData {connId} = cData1
-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
-    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
-    testCreateRcvMsg_ store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
-    testCreateRcvMsg_ store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
-    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
-    testCreateRcvMsg_ store 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
-    testCreateSndMsg_ store "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
-    testCreateSndMsg_ store "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
+    _ <- withTransaction st $ \db -> do
+      g <- newTVarIO =<< drgNew
+      createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    withTransaction st $ \db -> do
+      _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+      testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
+      testCreateRcvMsg_ db 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
+      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
+      testCreateRcvMsg_ db 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
+      testCreateSndMsg_ db "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
+      testCreateSndMsg_ db "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"

tests/NtfClient.hs

@@ -62,6 +62,9 @@ apnsTestPort = "6010"
 testKeyHash :: C.KeyHash
 testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 
+ntfTestStoreLogFile :: FilePath
+ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
+
 testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testNtfClient client =
   runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
@@ -81,21 +84,28 @@ ntfServerCfg =
       smpAgentCfg = defaultSMPClientAgentConfig,
       apnsConfig =
         defaultAPNSPushClientConfig
-          { apnsHost = "localhost",
-            apnsPort = apnsTestPort,
+          { apnsPort = apnsTestPort,
             http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
           },
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
+      storeLogFile = Nothing,
+      resubscribeDelay = 1000,
       -- CA certificate private key is not needed for initialization
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"
     }
 
+withNtfServerStoreLog :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ThreadId -> m a) -> m a
+withNtfServerStoreLog t = withNtfServerCfg t ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile}
+
 withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withNtfServerThreadOn t port' =
+withNtfServerThreadOn t port' = withNtfServerCfg t ntfServerCfg {transports = [(port', t)]}
+
+withNtfServerCfg :: (MonadUnliftIO m, MonadRandom m) => ATransport -> NtfServerConfig -> (ThreadId -> m a) -> m a
+withNtfServerCfg t cfg =
   serverBracket
-    (\started -> runNtfServerBlocking started ntfServerCfg {transports = [(port', t)]})
+    (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
     (pure ())
 
 serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a

tests/NtfServerTests.hs

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

tests/SMPAgentClient.hs

@@ -162,7 +162,7 @@ initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
     { smp = L.fromList [testSMPServer],
-      ntf = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
+      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
     }
 
 agentCfg :: AgentConfig
@@ -183,7 +183,8 @@ agentCfg =
             defaultTransport = (ntfTestPort, transport @TLS)
           },
       reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
-      ntfWorkerThrottle = 1000,
+      ntfWorkerDelay = 1000,
+      ntfSMPWorkerDelay = 1000,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"

tests/SMPClient.hs

@@ -22,6 +22,7 @@ import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.KeepAlive
+import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
@@ -46,6 +47,9 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
 testStoreMsgsFile :: FilePath
 testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 
+testServerStatsBackupFile :: FilePath
+testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
+
 testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testSMPClient client =
   runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
@@ -53,6 +57,9 @@ testSMPClient client =
       Right th -> client th
       Left e -> error $ show e
 
+cfgV2 :: ServerConfig
+cfgV2 = cfg {smpServerVRange = mkVersionRange 1 2}
+
 cfg :: ServerConfig
 cfg =
   ServerConfig
@@ -69,17 +76,21 @@ cfg =
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
+      serverStatsBackupFile = Nothing,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
       smpServerVRange = supportedSMPServerVRange
     }
 
+withSmpServerStoreMsgLogOnV2 :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
+
 withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
+withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile}
+withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
 withSmpServerConfigOn t cfg' port' =

tests/ServerTests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -13,6 +14,7 @@ import Control.Concurrent (ThreadId, killThread, threadDelay)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, try)
 import Control.Monad.Except (forM, forM_, runExceptT)
+import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -20,6 +22,7 @@ import SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
@@ -34,7 +37,8 @@ serverTests :: ATransport -> Spec
 serverTests t@(ATransport t') = do
   describe "SMP syntax" $ syntaxTests t
   describe "SMP queues" $ do
-    describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
+    describe "NEW and KEY commands, SEND messages (v2)" $ testCreateSecureV2 t'
+    describe "NEW and KEY commands, SEND messages (v3)" $ testCreateSecure t
     describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
     describe "Stress test" $ stressTest t
     describe "allowNewQueues setting" $ testAllowNewQueues t'
@@ -45,6 +49,7 @@ serverTests t@(ATransport t') = do
     describe "GET & SUB commands" $ testGetSubCommands t'
   describe "Store log" $ testWithStoreLog t
   describe "Restore messages" $ testRestoreMessages t
+  describe "Restore messages (v2)" $ testRestoreMessagesV2 t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
@@ -58,6 +63,9 @@ pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
 pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
 pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
 
+pattern Msg :: MsgId -> MsgBody -> BrokerMsg
+pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
+
 sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
 sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
@@ -80,21 +88,29 @@ _SEND = SEND noMsgFlags
 _SEND' :: MsgBody -> Command 'Sender
 _SEND' = SEND MsgFlags {notification = True}
 
-testCreateSecure :: ATransport -> Spec
-testCreateSecure (ATransport t) =
+decryptMsgV2 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either C.CryptoError ByteString
+decryptMsgV2 dhShared = C.cbDecrypt dhShared . C.cbNonce
+
+decryptMsgV3 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either String MsgBody
+decryptMsgV3 dhShared nonce body = do
+  ClientRcvMsgBody {msgBody} <- parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body)
+  pure msgBody
+
+testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec
+testCreateSecureV2 _ =
   it "should create (NEW) and secure (KEY) queue" $
-    smpTest t $ \h -> do
+    withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
-      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
+      let dec = decryptMsgV2 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
       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 mId1)
@@ -124,7 +140,7 @@ testCreateSecure (ATransport t) =
       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 mId2)
@@ -133,6 +149,77 @@ testCreateSecure (ATransport t) =
       Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, _SEND "hello")
       (err5, ERR AUTH) #== "rejects unsigned SEND"
 
+      let maxAllowedMessage = B.replicate maxMessageLength '-'
+      Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
+      Resp "" _ (Msg mId3 msg3) <- tGet h
+      (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
+
+      let biggerMessage = B.replicate (maxMessageLength + 1) '-'
+      Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv h sKey ("bcda", sId, _SEND biggerMessage)
+      pure ()
+
+testCreateSecure :: ATransport -> Spec
+testCreateSecure (ATransport t) =
+  it "should create (NEW) and secure (KEY) queue" $
+    smpTest t $ \h -> do
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
+      (rId1, "") #== "creates queue"
+
+      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
+      (dec mId1 msg1, Right "hello") #== "delivers message"
+
+      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 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")
+      (err1, ERR AUTH) #== "rejects signed SEND"
+      (sId2, sId) #== "same queue ID in response 2"
+
+      Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub)
+      (err2, ERR AUTH) #== "rejects KEY with wrong signature"
+
+      Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub)
+      (err3, ERR AUTH) #== "rejects KEY with sender's ID"
+
+      Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub)
+      (ok2, OK) #== "secures queue"
+      (rId2, rId) #== "same queue ID in response 3"
+
+      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")
+      (ok3, OK) #== "accepts signed SEND"
+
+      Resp "" _ (Msg mId2 msg2) <- tGet h
+      (dec mId2 msg2, Right "hello again") #== "delivers message 2"
+
+      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")
+      (err5, ERR AUTH) #== "rejects unsigned SEND"
+
+      let maxAllowedMessage = B.replicate maxMessageLength '-'
+      Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
+      Resp "" _ (Msg mId3 msg3) <- tGet h
+      (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
+
+      let biggerMessage = B.replicate (maxMessageLength + 1) '-'
+      Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv h sKey ("bcda", sId, _SEND biggerMessage)
+      pure ()
+
 testCreateDelete :: ATransport -> Spec
 testCreateDelete (ATransport t) =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
@@ -140,7 +227,7 @@ testCreateDelete (ATransport t) =
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
-      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
       (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
@@ -153,7 +240,7 @@ testCreateDelete (ATransport t) =
       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)
@@ -175,7 +262,7 @@ testCreateDelete (ATransport t) =
       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)
@@ -237,14 +324,14 @@ testDuplex (ATransport t) =
       (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
       (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub)
-      let aDec nonce = C.cbDecrypt (C.dh' aSrvDh aDhPriv) (C.cbNonce nonce)
+      let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
       -- 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)
       -- "key ..." is ad-hoc, not a part of SMP protocol
 
-      Resp "" _ (MSG mId1 _ _ msg1) <- tGet alice
+      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"
@@ -253,11 +340,11 @@ testDuplex (ATransport t) =
       (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
       (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)
+      let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
       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 "" _ (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"
@@ -266,7 +353,7 @@ testDuplex (ATransport t) =
       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 "" _ (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"
@@ -274,13 +361,13 @@ testDuplex (ATransport t) =
 
       Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
 
-      Resp "" _ (MSG mId4 _ _ msg4) <- tGet alice
+      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 "" _ (MSG mId5 _ _ msg5) <- tGet bob
+      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"
 
@@ -291,18 +378,18 @@ testSwitchSub (ATransport t) =
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
       (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)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       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")
       (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 mId1)
+      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 mId2')
 
@@ -311,7 +398,7 @@ testSwitchSub (ATransport t) =
 
       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 mId3)
@@ -334,9 +421,9 @@ testGetCommand t =
         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)
+        let dec = decryptMsgV3 dhShared
         Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello")
-        Resp "2" _ (MSG mId1 _ _ msg1) <- signSendRecv rh rKey ("2", rId, GET)
+        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)
@@ -348,14 +435,14 @@ testGetSubCommands t =
     (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)
+      let dec = decryptMsgV3 dhShared
       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)
+      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'
@@ -364,27 +451,27 @@ testGetSubCommands t =
       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)
+      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)
+      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)
+      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')
+      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)
+      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
@@ -406,7 +493,8 @@ testWithStoreLog at@(ATransport t) =
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
-      Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub)
+      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
+      Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey)
       atomically $ do
         writeTVar recipientId1 rId1
         writeTVar recipientKey1 $ Just rKey1
@@ -415,15 +503,15 @@ testWithStoreLog at@(ATransport t) =
         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
-      (C.cbDecrypt dhShared (C.cbNonce mId1) msg1, Right "hello") #== "delivered from queue 1"
-      Resp "" _ NMSG <- tGet h1
+      Resp "" _ (Msg mId1 msg1) <- tGet h
+      (decryptMsgV3 dhShared 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
-      (C.cbDecrypt dhShared2 (C.cbNonce mId2) msg2, Right "hello too") #== "delivered from queue 2"
+      Resp "" _ (Msg mId2 msg2) <- tGet h
+      (decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
 
       Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
       pure ()
@@ -445,9 +533,9 @@ testWithStoreLog at@(ATransport t) =
       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)
-      (C.cbDecrypt dh1 (C.cbNonce mId3) msg3, Right "hello") #== "delivered from restored queue"
-      Resp "" _ NMSG <- tGet h1
+      Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
+      (decryptMsgV3 dh1 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")
@@ -488,9 +576,9 @@ testRestoreMessages at@(ATransport t) =
           writeTVar dhShared $ Just dh
           writeTVar senderId sId
         Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
-        Resp "" _ (MSG mId1 _ _ msg1) <- tGet h1
+        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"
+        (decryptMsgV3 dh 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")
@@ -505,12 +593,13 @@ testRestoreMessages at@(ATransport t) =
       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"
+      let dec = decryptMsgV3 dh
+      Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
+      (dec mId2 msg2, Right "hello 2") #== "restored message delivered"
+      Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
+      (dec mId3 msg3, Right "hello 3") #== "restored message delivered"
+      Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3)
+      (dec mId4 msg4, Right "hello 4") #== "restored message delivered"
 
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
@@ -520,9 +609,78 @@ testRestoreMessages at@(ATransport t) =
       rId <- readTVarIO recipientId
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
-      Resp "4" _ (MSG mId4 _ _ msg4) <- signSendRecv h rKey ("4", rId, SUB)
+      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"
+      (decryptMsgV3 dh 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` ()
+
+testRestoreMessagesV2 :: ATransport -> Spec
+testRestoreMessagesV2 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 ""
+
+    withSmpServerStoreMsgLogOnV2 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)
+        (decryptMsgV2 dh 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
+
+    withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
+      rId <- readTVarIO recipientId
+      Just rKey <- readTVarIO recipientKey
+      Just dh <- readTVarIO dhShared
+      let dec = decryptMsgV2 dh
+      Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
+      (dec mId2 msg2, Right "hello 2") #== "restored message delivered"
+      Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
+      (dec mId3 msg3, Right "hello 3") #== "restored message delivered"
+      Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3)
+      (dec 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
+
+    withSmpServerStoreMsgLogOnV2 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)
+      (decryptMsgV2 dh mId4 msg4, Right "hello 4") #== "restored message delivered"
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
@@ -567,7 +725,7 @@ testTiming (ATransport t) =
       (rPub, rKey) <- generateKeys goodKeySize
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
-      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
 
       (_, badKey) <- generateKeys badKeySize
@@ -577,7 +735,7 @@ testTiming (ATransport t) =
       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 "" _ (Msg mId msg) <- tGet rh
       (dec mId msg, Right "hello") #== "delivered from queue"
 
       runTimingTest sh badKey sId $ _SEND "hello"
@@ -609,23 +767,34 @@ testMessageNotifications (ATransport t) =
     (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
     smpTest4 t $ \rh sh nh1 nh2 -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
-      let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
-      Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, NKEY nPub)
+      let dec = decryptMsgV3 dhShared
+      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
+      Resp "1" _ (NID nId' _) <- signSendRecv rh rKey ("1", rId, NKEY nPub rcvNtfPubDhKey)
+      Resp "1a" _ (NID nId _) <- signSendRecv rh rKey ("1a", rId, NKEY nPub rcvNtfPubDhKey)
+      nId' `shouldNotBe` nId
       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 "" _ (Msg mId1 msg1) <- tGet rh
       (dec mId1 msg1, Right "hello") #== "delivered from queue"
       Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
-      Resp "" _ NMSG <- tGet nh1
+      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 "" _ (Msg mId2 msg2) <- tGet rh
+      Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
       (dec mId2 msg2, Right "hello again") #== "delivered from queue again"
-      Resp "" _ NMSG <- tGet nh2
+      Resp "" _ (NMSG _ _) <- tGet nh2
       1000 `timeout` tGet @BrokerMsg nh1 >>= \case
-        Nothing -> return ()
+        Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
+      Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
+      Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
+      Resp "" _ (Msg mId3 msg3) <- tGet rh
+      (dec mId3 msg3, Right "hello there") #== "delivered from queue again"
+      1000 `timeout` tGet @BrokerMsg nh2 >>= \case
+        Nothing -> pure ()
+        Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
 
 testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec
 testMsgExpireOnSend t =
@@ -635,12 +804,12 @@ testMsgExpireOnSend t =
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
+        let dec = decryptMsgV3 dhShared
         Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
         threadDelay 2500000
         Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)")
         testSMPClient @c $ \rh -> do
-          Resp "3" _ (MSG mId _ _ msg) <- signSendRecv rh rKey ("3", rId, SUB)
+          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 ()
@@ -670,11 +839,11 @@ testMsgNOTExpireOnInterval t =
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
-        let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)
+        let dec = decryptMsgV3 dhShared
         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 ()