From 5ca593415bb1a1bcb773cde46e7c22d8b2caef72 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Thu, 29 May 2025 15:02:38 +0200
Subject: [PATCH 01/19] List ntf servers

---
 src/Simplex/Messaging/Agent.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 799fed250..6d9f5bd59 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -98,6 +98,7 @@ module Simplex.Messaging.Agent
     verifyNtfToken,
     checkNtfToken,
     deleteNtfToken,
+    getNtfServers,
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
@@ -2381,6 +2382,10 @@ setNtfServers :: AgentClient -> [NtfServer] -> IO ()
 setNtfServers c = atomically . writeTVar (ntfServers c)
 {-# INLINE setNtfServers #-}
 
+getNtfServers :: AgentClient -> IO [NtfServer]
+getNtfServers c =  readTVarIO $ ntfServers c
+{-# INLINE getNtfServers #-}
+
 resetAgentServersStats' :: AgentClient -> AM ()
 resetAgentServersStats' c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do
   startedAt <- liftIO getCurrentTime

From 8d1f3738072924caf550ddfec9208af18c7926dc Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 17 Jun 2025 11:40:20 +0200
Subject: [PATCH 02/19] Treat ntf servers as other user servers

Once ntf servers will be able to send webpush requests
they won't be tight to an application developer like for
iOS where ntf servers have to know a secret. They will
all have their own VAPID key. So it will be possible for
users to choose what servers they want to use.
---
 src/Simplex/Messaging/Agent.hs                | 88 ++++++++++---------
 src/Simplex/Messaging/Agent/Client.hs         |  5 +-
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |  2 +-
 .../Messaging/Agent/NtfSubSupervisor.hs       | 12 ---
 src/Simplex/Messaging/Agent/Protocol.hs       |  1 +
 src/Simplex/Messaging/Notifications/Types.hs  |  2 +-
 src/Simplex/Messaging/Protocol.hs             |  4 +-
 tests/AgentTests/NotificationTests.hs         |  8 +-
 8 files changed, 60 insertions(+), 62 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 6d9f5bd59..e006669ac 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -98,7 +98,6 @@ module Simplex.Messaging.Agent
     verifyNtfToken,
     checkNtfToken,
     deleteNtfToken,
-    getNtfServers,
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
@@ -213,7 +212,7 @@ import Simplex.Messaging.Protocol
     SubscriptionMode (..),
     UserProtocol,
     VersionSMPC,
-    senderCanSecure,
+    senderCanSecure, NtfServerWithAuth,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
@@ -317,8 +316,8 @@ resumeAgentClient :: AgentClient -> IO ()
 resumeAgentClient c = atomically $ writeTVar (active c) True
 {-# INLINE resumeAgentClient #-}
 
-createUser :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AE UserId
-createUser c = withAgentEnv c .: createUser' c
+createUser :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> NonEmpty (ServerCfg 'PNTF) -> AE UserId
+createUser c = withAgentEnv c .:. createUser' c
 {-# INLINE createUser #-}
 
 -- | Delete user record optionally deleting all user's connections on SMP servers
@@ -577,13 +576,13 @@ reconnectAllServers c = do
   reconnectServerClients c ntfClients
 
 -- | Register device notifications token
-registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
-registerNtfToken c = withAgentEnv c .: registerNtfToken' c
+registerNtfToken :: AgentClient -> UserId -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken c userId = withAgentEnv c .: registerNtfToken' c userId
 {-# INLINE registerNtfToken #-}
 
 -- | Verify device notifications token
-verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
-verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c
+verifyNtfToken :: AgentClient -> UserId -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken c userId = withAgentEnv c .:. verifyNtfToken' c userId
 {-# INLINE verifyNtfToken #-}
 
 checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
@@ -697,13 +696,15 @@ logConnection c connected =
   let event = if connected then "connected to" else "disconnected from"
    in logInfo $ T.unwords ["client", tshow (clientId c), event, "Agent"]
 
-createUser' :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AM UserId
-createUser' c smp xftp = do
+createUser' :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> NonEmpty (ServerCfg 'PNTF) -> AM UserId
+createUser' c smp xftp ntf = do
   liftIO $ checkUserServers "createUser SMP" smp
   liftIO $ checkUserServers "createUser XFTP" xftp
+  liftIO $ checkUserServers "createUser NTF" ntf
   userId <- withStore' c createUserRecord
   atomically $ TM.insert userId (mkUserServers smp) $ smpServers c
   atomically $ TM.insert userId (mkUserServers xftp) $ xftpServers c
+  atomically $ TM.insert userId (mkUserServers ntf) $ ntfServers c
   pure userId
 
 deleteUser' :: AgentClient -> UserId -> Bool -> AM ()
@@ -2177,8 +2178,8 @@ checkUserServers name srvs =
   unless (any (\ServerCfg {enabled} -> enabled) srvs) $
     logWarn (name <> ": all passed servers are disabled, using all servers.")
 
-registerNtfToken' :: AgentClient -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
-registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
+registerNtfToken' :: AgentClient -> UserId -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
+registerNtfToken' c userId suppliedDeviceToken suppliedNtfMode =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
       status <- case (ntfTokenId, ntfTknAction) of
@@ -2222,30 +2223,28 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
               else do
                 withStore' c $ \db -> removeNtfToken db tkn
                 atomically $ nsRemoveNtfToken ns
-                createToken
+                createToken userId
           where
             tryReplace ns = do
               agentNtfReplaceToken c tknId tkn suppliedDeviceToken
               withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
               atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
               pure NTRegistered
-    _ -> createToken
+    _ -> createToken userId
   where
-    t tkn = withToken c tkn Nothing
-    createToken :: AM NtfTknStatus
-    createToken =
-      lift (getNtfServer c) >>= \case
-        Just ntfServer ->
-          asks (rcvAuthAlg . config) >>= \case
-            C.AuthAlg a -> do
-              g <- asks random
-              tknKeys <- atomically $ C.generateAuthKeyPair a g
-              dhKeys <- atomically $ C.generateKeyPair g
-              let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode
-              withStore' c (`createNtfToken` tkn)
-              registerToken tkn
-              pure NTRegistered
-        _ -> throwE $ CMD PROHIBITED "createToken"
+    t tkn = withToken c userId tkn Nothing
+    createToken :: UserId -> AM NtfTknStatus
+    createToken userId = do
+      ntfServer <- getNtfServer c userId
+      asks (rcvAuthAlg . config) >>= \case
+        C.AuthAlg a -> do
+          g <- asks random
+          tknKeys <- atomically $ C.generateAuthKeyPair a g
+          dhKeys <- atomically $ C.generateKeyPair g
+          let tkn = newNtfToken suppliedDeviceToken (protoServer ntfServer) tknKeys dhKeys suppliedNtfMode
+          withStore' c (`createNtfToken` tkn)
+          registerToken tkn
+          pure NTRegistered
     registerToken :: NtfToken -> AM ()
     registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
       (tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
@@ -2254,14 +2253,14 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
       ns <- asks ntfSupervisor
       atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
 
-verifyNtfToken' :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
-verifyNtfToken' c deviceToken nonce code =
+verifyNtfToken' :: AgentClient -> UserId -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
+verifyNtfToken' c userId deviceToken nonce code =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
       when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "verifyNtfToken: different token"
       code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
       toStatus <-
-        withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
+        withToken c userId tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
           agentNtfVerifyToken c tknId tkn code'
       when (toStatus == NTActive) $ do
         lift $ setCronInterval c tknId tkn
@@ -2327,8 +2326,8 @@ toggleConnectionNtfs' c connId enable = do
           let cmd = if enable then NSCCreate else NSCSmpDelete
           atomically $ sendNtfSubCommand ns (cmd, [connId])
 
-withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
-withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
+withToken :: AgentClient -> UserId -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
+withToken c userId tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
   ns <- asks ntfSupervisor
   forM_ from_ $ \(status, action) -> do
     withStore' c $ \db -> updateNtfToken db tkn status (Just action)
@@ -2342,7 +2341,7 @@ withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f =
     Left e@(NTF _ AUTH) -> do
       withStore' c $ \db -> removeNtfToken db tkn
       atomically $ nsRemoveNtfToken ns
-      void $ registerNtfToken' c deviceToken ntfMode
+      void $ registerNtfToken' c userId deviceToken ntfMode
       throwE e
     Left e -> throwE e
 
@@ -2378,14 +2377,13 @@ sendNtfConnCommands c cmd = do
           (connId, Right Nothing) -> (cIds, (connId, INTERNAL "no connection data") : errs)
           (connId, Left e) -> (cIds, (connId, e) : errs)
 
-setNtfServers :: AgentClient -> [NtfServer] -> IO ()
-setNtfServers c = atomically . writeTVar (ntfServers c)
+setNtfServers :: AgentClient -> Map UserId (NonEmpty (ServerCfg 'PNTF)) -> IO ()
+setNtfServers c ntfs = do
+  atomically $ writeTVar (ntfServers c) newNtfs
+  where
+    newNtfs = M.map mkUserServers ntfs
 {-# INLINE setNtfServers #-}
 
-getNtfServers :: AgentClient -> IO [NtfServer]
-getNtfServers c =  readTVarIO $ ntfServers c
-{-# INLINE getNtfServers #-}
-
 resetAgentServersStats' :: AgentClient -> AM ()
 resetAgentServersStats' c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do
   startedAt <- liftIO getCurrentTime
@@ -2448,6 +2446,14 @@ getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
 getNextSMPServer c userId = getNextServer c userId storageSrvs
 {-# INLINE getNextSMPServer #-}
 
+getNtfServer :: AgentClient -> UserId -> AM NtfServerWithAuth
+getNtfServer c userId = getNextNtfServer c userId []
+{-# INLINE getNtfServer #-}
+
+getNextNtfServer :: AgentClient -> UserId -> [NtfServer] -> AM NtfServerWithAuth
+getNextNtfServer c userId = getNextServer c userId storageSrvs
+{-# INLINE getNextNtfServer #-}
+
 subscriber :: AgentClient -> AM' ()
 subscriber c@AgentClient {msgQ} = forever $ do
   t <- atomically $ readTBQueue msgQ
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index bd072fed2..a32df2acb 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -321,7 +321,7 @@ data AgentClient = AgentClient
     -- SMPTransportSession defines connection from proxy to relay,
     -- SMPServerWithAuth defines client connected to SMP proxy (with the same userId and entityId in TransportSession)
     smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth,
-    ntfServers :: TVar [NtfServer],
+    ntfServers :: TMap UserId (UserServers 'PNTF),
     ntfClients :: TMap NtfTransportSession NtfClientVar,
     xftpServers :: TMap UserId (UserServers 'PXFTP),
     xftpClients :: TMap XFTPTransportSession XFTPClientVar,
@@ -490,7 +490,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
   smpServers <- newTVarIO $ M.map mkUserServers smp
   smpClients <- TM.emptyIO
   smpProxiedRelays <- TM.emptyIO
-  ntfServers <- newTVarIO ntf
+  ntfServers <- newTVarIO $ M.map mkUserServers ntf
   ntfClients <- TM.emptyIO
   xftpServers <- newTVarIO $ M.map mkUserServers xftp
   xftpClients <- TM.emptyIO
@@ -2138,6 +2138,7 @@ userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMa
 userServers c = case protocolTypeI @p of
   SPSMP -> smpServers c
   SPXFTP -> xftpServers c
+  SPNTF -> ntfServers c
 {-# INLINE userServers #-}
 
 pickServer :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index 0c10d8cd4..d2001c110 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -94,7 +94,7 @@ type AM a = ExceptT AgentErrorType (ReaderT Env IO) a
 
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
-    ntf :: [NtfServer],
+    ntf :: Map UserId (NonEmpty (ServerCfg 'PNTF)),
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
     netCfg :: NetworkConfig,
     presetDomains :: [HostName]
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 3da1b74b6..14bd51d56 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -17,7 +17,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     instantNotifications,
     deleteToken,
     closeNtfSupervisor,
-    getNtfServer,
   )
 where
 
@@ -582,14 +581,3 @@ closeNtfSupervisor ns = do
   stopWorkers $ ntfTknDelWorkers ns
   where
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
-
-getNtfServer :: AgentClient -> AM' (Maybe NtfServer)
-getNtfServer c = do
-  ntfServers <- readTVarIO $ ntfServers c
-  case ntfServers of
-    [] -> pure Nothing
-    [srv] -> pure $ Just srv
-    servers -> do
-      gen <- asks randomServer
-      atomically . stateTVar gen $
-        first (Just . (servers !!)) . randomR (0, length servers - 1)
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 463639942..3ada0335e 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -222,6 +222,7 @@ import Simplex.Messaging.Protocol
     MsgFlags,
     MsgId,
     NMsgMeta,
+    NtfServerWithAuth,
     ProtocolServer (..),
     QueueMode (..),
     SMPClientVersion,
diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs
index 4a335c964..f0dc1eb03 100644
--- a/src/Simplex/Messaging/Notifications/Types.hs
+++ b/src/Simplex/Messaging/Notifications/Types.hs
@@ -14,7 +14,7 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (.
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
+import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer, NtfServerWithAuth)
 
 data NtfTknAction
   = NTARegister
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index cb2eea43b..b52f6e2b4 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -1090,6 +1090,7 @@ instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP
 type family UserProtocol (p :: ProtocolType) :: Constraint where
   UserProtocol PSMP = ()
   UserProtocol PXFTP = ()
+  UserProtocol PNTF = ()
   UserProtocol a =
     (Int ~ Bool, TypeError (TE.Text "Servers for protocol " :<>: ShowType a :<>: TE.Text " cannot be configured by the users"))
 
@@ -1097,7 +1098,8 @@ userProtocol :: SProtocolType p -> Maybe (Dict (UserProtocol p))
 userProtocol = \case
   SPSMP -> Just Dict
   SPXFTP -> Just Dict
-  _ -> Nothing
+  SPNTF -> Just Dict
+  -- _ -> Nothing
 
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs
index 2c3ba40d4..eae23f3e0 100644
--- a/tests/AgentTests/NotificationTests.hs
+++ b/tests/AgentTests/NotificationTests.hs
@@ -452,7 +452,7 @@ testNtfTokenChangeServers t apns =
     tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
       tkn <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn
-      liftIO $ setNtfServers a [testNtfServer2]
+      liftIO $ setNtfServers a [noAuthSrvCfg testNtfServer2]
       NTActive <- checkNtfToken a tkn -- still works on old server
       pure tkn
 
@@ -462,7 +462,7 @@ testNtfTokenChangeServers t apns =
       runRight_ $ do
         getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
         NTActive <- checkNtfToken a tkn1
-        liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
+        liftIO $ setNtfServers a [noAuthSrvCfg testNtfServer2] -- just change configured server list
         getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
         -- trigger token replace
         tkn2 <- registerTestToken a "xyzw" NMInstant apns
@@ -894,7 +894,7 @@ testNotificationsOldToken apns =
     liftIO $ threadDelay 250000
     testMessageAB "hello"
     -- change server
-    liftIO $ setNtfServers a [testNtfServer2] -- server 2 isn't running now, don't use
+    liftIO $ setNtfServers a [noAuthSrvCfg testNtfServer2] -- server 2 isn't running now, don't use
     -- replacing token keeps server
     _ <- registerTestToken a "xyzw" NMInstant apns
     getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
@@ -914,7 +914,7 @@ testNotificationsNewToken apns oldNtf =
     liftIO $ threadDelay 250000
     testMessageAB "hello"
     -- switch
-    liftIO $ setNtfServers a [testNtfServer2]
+    liftIO $ setNtfServers a [noAuthSrvCfg testNtfServer2]
     deleteNtfToken a tkn
     _ <- registerTestToken a "abcd" NMInstant apns
     getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort2

From b49d56ed4388a72a61fff5f0c65accf09a555042 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Thu, 26 Jun 2025 16:59:25 +0200
Subject: [PATCH 03/19] Move generic push functions to Push.hs

---
 .../Messaging/Notifications/Server/Push.hs    | 81 +++++++++++++++++++
 .../Notifications/Server/Push/APNS.hs         | 59 +-------------
 2 files changed, 82 insertions(+), 58 deletions(-)
 create mode 100644 src/Simplex/Messaging/Notifications/Server/Push.hs

diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs
new file mode 100644
index 000000000..0320b8c51
--- /dev/null
+++ b/src/Simplex/Messaging/Notifications/Server/Push.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+
+module Simplex.Messaging.Notifications.Server.Push where
+
+import Crypto.Hash.Algorithms (SHA256 (..))
+import qualified Crypto.PubKey.ECC.ECDSA as EC
+import qualified Crypto.PubKey.ECC.Types as ECT
+import qualified Crypto.Store.PKCS8 as PK
+import Data.ASN1.BinaryEncoding (DER (..))
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteString.Base64.URL as U
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Text (Text)
+import Data.Time.Clock.System
+import qualified Data.X509 as X
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Parsers (defaultJSON)
+
+data JWTHeader = JWTHeader
+  { alg :: Text, -- key algorithm, ES256 for APNS
+    kid :: Text -- key ID
+  }
+  deriving (Show)
+
+data JWTClaims = JWTClaims
+  { iss :: Text, -- issuer, team ID for APNS
+    iat :: Int64 -- issue time, seconds from epoch
+  }
+  deriving (Show)
+
+data JWTToken = JWTToken JWTHeader JWTClaims
+  deriving (Show)
+
+mkJWTToken :: JWTHeader -> Text -> IO JWTToken
+mkJWTToken hdr iss = do
+  iat <- systemSeconds <$> getSystemTime
+  pure $ JWTToken hdr JWTClaims {iss, iat}
+
+type SignedJWTToken = ByteString
+
+$(JQ.deriveToJSON defaultJSON ''JWTHeader)
+
+$(JQ.deriveToJSON defaultJSON ''JWTClaims)
+
+signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTToken pk (JWTToken hdr claims) = do
+  let hc = jwtEncode hdr <> "." <> jwtEncode claims
+  sig <- EC.sign pk SHA256 hc
+  pure $ hc <> "." <> serialize sig
+  where
+    jwtEncode :: ToJSON a => a -> ByteString
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+
+readECPrivateKey :: FilePath -> IO EC.PrivateKey
+readECPrivateKey f = do
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
+  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
+
+data PushNotification
+  = PNVerification NtfRegCode
+  | PNMessage (NonEmpty PNMessageData)
+  | -- | PNAlert Text
+    PNCheckMessages
+  deriving (Show)
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index 39aeb9329..da647253e 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -16,14 +16,8 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
-import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
 import Crypto.Random (ChaChaDRG)
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
 import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -32,18 +26,15 @@ import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.Int (Int64)
 import Data.List (find)
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.System
-import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Network.HPACK.Token as HT
 import Network.HTTP.Types (Status)
@@ -53,6 +44,7 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
@@ -62,55 +54,6 @@ import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show)
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show)
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-$(JQ.deriveToJSON defaultJSON ''JWTHeader)
-
-$(JQ.deriveToJSON defaultJSON ''JWTClaims)
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
-  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
-  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
-
-data PushNotification
-  = PNVerification NtfRegCode
-  | PNMessage (NonEmpty PNMessageData)
-  | -- | PNAlert Text
-    PNCheckMessages
-  deriving (Show)
-
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show)
 

From 0a6df0d5cc33e969b7f9a54959987d4dfe256bfa Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Mon, 30 Jun 2025 09:15:34 +0200
Subject: [PATCH 04/19] Add WPDeviceToken to prepare WebPush support

---
 simplexmq.cabal                               |  1 +
 src/Simplex/Messaging/Agent/Client.hs         |  2 +-
 .../Messaging/Agent/Store/AgentStore.hs       | 27 +++--
 .../Messaging/Notifications/Protocol.hs       | 98 ++++++++++++++++---
 src/Simplex/Messaging/Notifications/Server.hs | 19 ++--
 .../Messaging/Notifications/Server/Env.hs     |  1 +
 .../Notifications/Server/Push/APNS.hs         |  8 +-
 .../Notifications/Server/Store/Postgres.hs    | 13 ++-
 8 files changed, 134 insertions(+), 35 deletions(-)

diff --git a/simplexmq.cabal b/simplexmq.cabal
index e49a72a1f..f0fbf7c4f 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -254,6 +254,7 @@ library
               Simplex.Messaging.Notifications.Server.Main
               Simplex.Messaging.Notifications.Server.Prometheus
               Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push
               Simplex.Messaging.Notifications.Server.Push.APNS.Internal
               Simplex.Messaging.Notifications.Server.Stats
               Simplex.Messaging.Notifications.Server.Store
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index a32df2acb..13c2defbb 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -1309,7 +1309,7 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
         (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
         (dhKey, _) <- atomically $ C.generateKeyPair g
         r <- runExceptT $ do
-          let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
+          let deviceToken = APNSDeviceToken PPApnsNull "test_ntf_token"
           (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey)
           liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId
         ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf
diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
index 446681b70..30de731a8 100644
--- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs
+++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
@@ -278,7 +278,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), Ratc
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceTokenFields, deviceToken')
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
@@ -1381,7 +1381,8 @@ deleteCommand db cmdId =
   DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
 
 createNtfToken :: DB.Connection -> NtfToken -> IO ()
-createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
+createNtfToken db NtfToken {deviceToken, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
+  let (provider, token) = deviceTokenFields deviceToken
   upsertNtfServer_ db srv
   DB.execute
     db
@@ -1408,10 +1409,12 @@ getSavedNtfToken db = do
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
+          deviceToken = deviceToken' provider dt
+       in NtfToken {deviceToken, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
 updateNtfTokenRegistration :: DB.Connection -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> IO ()
-updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do
+updateNtfTokenRegistration db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1423,8 +1426,10 @@ updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token
     (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO ()
-updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} (DeviceToken toProvider toToken) = do
+updateDeviceToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} toDt = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
+  let (toProvider, toToken) = deviceTokenFields toDt
   DB.execute
     db
     [sql|
@@ -1435,7 +1440,8 @@ updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServ
     (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO ()
-updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do
+updateNtfMode db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} ntfMode = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1447,7 +1453,8 @@ updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer =
     (ntfMode, updatedAt, provider, token, host, port)
 
 updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
-updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do
+updateNtfToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1459,7 +1466,8 @@ updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
     (tknStatus, tknAction, updatedAt, provider, token, host, port)
 
 removeNtfToken :: DB.Connection -> NtfToken -> IO ()
-removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} =
+removeNtfToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} = do
+  let (provider, token) = deviceTokenFields deviceToken
   DB.execute
     db
     [sql|
@@ -1784,7 +1792,8 @@ getActiveNtfToken db =
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
+          deviceToken = deviceToken' provider dt
+       in NtfToken {deviceToken, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
 getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime))
 getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs
index 769c35510..00f59d219 100644
--- a/src/Simplex/Messaging/Notifications/Protocol.hs
+++ b/src/Simplex/Messaging/Notifications/Protocol.hs
@@ -35,6 +35,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake)
 import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
 import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
+import Control.Monad (when)
 
 data NtfEntity = Token | Subscription
   deriving (Show)
@@ -372,6 +373,7 @@ data PushProvider
   | PPApnsProd -- production environment, including TestFlight
   | PPApnsTest -- used for tests, to use APNS mock server
   | PPApnsNull -- used to test servers from the client - does not communicate with APNS
+  | PPWebPush -- used for webpush (FCM, UnifiedPush, potentially desktop)
   deriving (Eq, Ord, Show)
 
 instance Encoding PushProvider where
@@ -380,12 +382,14 @@ instance Encoding PushProvider where
     PPApnsProd -> "AP"
     PPApnsTest -> "AT"
     PPApnsNull -> "AN"
+    PPWebPush -> "WP"
   smpP =
     A.take 2 >>= \case
       "AD" -> pure PPApnsDev
       "AP" -> pure PPApnsProd
       "AT" -> pure PPApnsTest
       "AN" -> pure PPApnsNull
+      "WP" -> pure PPWebPush
       _ -> fail "bad PushProvider"
 
 instance StrEncoding PushProvider where
@@ -394,44 +398,116 @@ instance StrEncoding PushProvider where
     PPApnsProd -> "apns_prod"
     PPApnsTest -> "apns_test"
     PPApnsNull -> "apns_null"
+    PPWebPush -> "webpush"
   strP =
     A.takeTill (== ' ') >>= \case
       "apns_dev" -> pure PPApnsDev
       "apns_prod" -> pure PPApnsProd
       "apns_test" -> pure PPApnsTest
       "apns_null" -> pure PPApnsNull
+      "webpush" -> pure PPWebPush
       _ -> fail "bad PushProvider"
 
 instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
 instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
 
-data DeviceToken = DeviceToken PushProvider ByteString
+data WPEndpoint = WPEndpoint { endpoint::ByteString, auth::ByteString, p256dh::ByteString }
+  deriving (Eq, Ord, Show)
+
+instance Encoding WPEndpoint where
+  smpEncode WPEndpoint { endpoint, auth, p256dh } = smpEncode (endpoint, auth, p256dh)
+  smpP = do
+    endpoint <- smpP
+    auth <- smpP
+    p256dh <- smpP
+    pure WPEndpoint { endpoint, auth, p256dh }
+
+instance StrEncoding WPEndpoint where
+  strEncode WPEndpoint { endpoint, auth, p256dh } = endpoint <> " " <> strEncode auth <> " " <> strEncode p256dh
+  strP = do
+    endpoint <- A.takeWhile (/= ' ')
+    _ <- A.char ' '
+    (auth, p256dh) <- strP
+    -- auth is a 16 bytes long random key
+    when (B.length auth /= 16) $ fail "Invalid auth key length"
+    -- p256dh is a public key on the P-256 curve, encoded in uncompressed format
+    -- 0x04 + the 2 points = 65 bytes
+    when (B.length p256dh /= 65) $ fail "Invalid p256dh key length"
+    when (B.take 1 p256dh /= "\x04") $ fail "Invalid p256dh key, doesn't start with 0x04"
+    pure WPEndpoint { endpoint, auth, p256dh }
+
+instance ToJSON WPEndpoint where
+  toEncoding WPEndpoint { endpoint, auth, p256dh } = J.pairs $ "endpoint" .= decodeLatin1 endpoint <> "auth" .= decodeLatin1 (strEncode auth) <> "p256dh" .= decodeLatin1 (strEncode p256dh)
+  toJSON WPEndpoint { endpoint, auth, p256dh } = J.object ["endpoint" .= decodeLatin1 endpoint, "auth" .= decodeLatin1 (strEncode auth), "p256dh" .= decodeLatin1 (strEncode p256dh) ]
+
+instance FromJSON WPEndpoint where
+  parseJSON = J.withObject "WPEndpoint" $ \o -> do
+    endpoint <- encodeUtf8 <$> o .: "endpoint"
+    auth <- strDecode . encodeUtf8 <$?> o .: "auth"
+    p256dh <- strDecode . encodeUtf8 <$?> o .: "p256dh"
+    pure WPEndpoint { endpoint, auth, p256dh }
+
+data DeviceToken
+  = APNSDeviceToken PushProvider ByteString
+  | WPDeviceToken WPEndpoint
   deriving (Eq, Ord, Show)
 
 instance Encoding DeviceToken where
-  smpEncode (DeviceToken p t) = smpEncode (p, t)
-  smpP = DeviceToken <$> smpP <*> smpP
+  smpEncode token = case token of
+    APNSDeviceToken p t -> smpEncode (p, t)
+    WPDeviceToken t -> smpEncode (PPWebPush, t)
+  smpP = do
+    pp <- smpP
+    case pp of
+      PPWebPush -> WPDeviceToken <$> smpP
+      _ -> APNSDeviceToken pp <$> smpP
 
 instance StrEncoding DeviceToken where
-  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = nullToken <|> hexToken
+  strEncode token = case token of
+    APNSDeviceToken p t -> strEncode p <> " " <> t
+    WPDeviceToken t -> strEncode PPWebPush <> " " <> strEncode t
+  strP = nullToken <|> deviceToken
     where
-      nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token"
-      hexToken = DeviceToken <$> strP <* A.space <*> hexStringP
+      nullToken = "apns_null test_ntf_token" $> APNSDeviceToken PPApnsNull "test_ntf_token"
+      deviceToken = do
+        pp <- strP_
+        case pp of
+          PPWebPush -> WPDeviceToken <$> strP
+          _ -> APNSDeviceToken pp <$> hexStringP
       hexStringP =
         A.takeWhile (`B.elem` "0123456789abcdef") >>= \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]
+  toEncoding token = case token of
+    APNSDeviceToken pp t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
+    WPDeviceToken t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode PPWebPush) <> "token" .= toJSON t
+  toJSON token = case token of
+    APNSDeviceToken pp t -> J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
+    WPDeviceToken t -> J.object ["pushProvider" .= decodeLatin1 (strEncode PPWebPush), "token" .= toJSON t]
 
 instance FromJSON DeviceToken where
   parseJSON = J.withObject "DeviceToken" $ \o -> do
     pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider"
-    t <- encodeUtf8 <$> o .: "token"
-    pure $ DeviceToken pp t
+    case pp of
+      PPWebPush -> do
+        WPDeviceToken <$> (o .: "token")
+      _ -> do
+        t <- encodeUtf8 <$> (o .: "token")
+        pure $ APNSDeviceToken pp t
+
+-- | Returns fields for the device token (pushProvider, token)
+deviceTokenFields :: DeviceToken -> (PushProvider, ByteString)
+deviceTokenFields dt = case dt of
+      APNSDeviceToken pp t -> (pp, t)
+      WPDeviceToken t -> (PPWebPush, strEncode t)
+
+-- | Returns the device token from the fields (pushProvider, token)
+deviceToken' :: PushProvider -> ByteString -> DeviceToken
+deviceToken' pp t = case pp of
+      PPWebPush -> WPDeviceToken <$> either error id $ strDecode t
+      _ -> APNSDeviceToken pp t
 
 -- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
 -- because strEncode of NonEmpty list uses comma for separator,
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 0bbc30824..29ac44d4d 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -56,7 +56,8 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Prometheus
-import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Push (PushNotification(..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (PushProviderError (..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf)
 import Simplex.Messaging.Notifications.Server.Store.Postgres
@@ -567,7 +568,8 @@ showServer' = decodeLatin1 . strEncode . host
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  (tkn@NtfTknRec {ntfTknId, token, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  let (pp, _) = deviceTokenFields token
   liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   st <- asks store
   case ntf of
@@ -575,19 +577,19 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
       liftIO (deliverNotification st pp tkn ntf) >>= \case
         Right _ -> do
           void $ liftIO $ setTknStatusConfirmed st tkn
-          incNtfStatT t ntfVrfDelivered
-        Left _ -> incNtfStatT t ntfVrfFailed
+          incNtfStatT token ntfVrfDelivered
+        Left _ -> incNtfStatT token ntfVrfFailed
     PNCheckMessages -> do
       liftIO (deliverNotification st pp tkn ntf) >>= \case
         Right _ -> do
           void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime
-          incNtfStatT t ntfCronDelivered
-        Left _ -> incNtfStatT t ntfCronFailed
+          incNtfStatT token ntfCronDelivered
+        Left _ -> incNtfStatT token ntfCronFailed
     PNMessage {} -> checkActiveTkn tknStatus $ do
       stats <- asks serverStats
       liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
       liftIO (deliverNotification st pp tkn ntf)
-        >>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered)
+        >>= incNtfStatT token . (\case Left _ -> ntfFailed; Right () -> ntfDelivered)
   where
     checkActiveTkn :: NtfTknStatus -> M () -> M ()
     checkActiveTkn status action
@@ -607,6 +609,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
             void $ updateTknStatus st tkn $ NTInvalid $ Just r
             err e
           PPPermanentError -> err e
+          PPInvalidPusher -> err e
       where
         retryDeliver :: IO (Either PushProviderError ())
         retryDeliver = do
@@ -838,7 +841,7 @@ withNtfStore stAction continue = do
     Right a -> continue a
 
 incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
-incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
+incNtfStatT (APNSDeviceToken PPApnsNull _) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 {-# INLINE incNtfStatT #-}
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index 42632a7a7..2ef02b23f 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -24,6 +24,7 @@ import Numeric.Natural
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index da647253e..dc2f54193 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -131,6 +131,7 @@ apnsProviderHost = \case
   PPApnsTest -> Just "localhost"
   PPApnsDev -> Just "api.sandbox.push.apple.com"
   PPApnsProd -> Just "api.push.apple.com"
+  _ -> Nothing
 
 defaultAPNSPushClientConfig :: APNSPushClientConfig
 defaultAPNSPushClientConfig =
@@ -258,6 +259,7 @@ data PushProviderError
   | PPTokenInvalid NTInvalidReason
   | PPRetryLater
   | PPPermanentError
+  | PPInvalidPusher
   deriving (Show, Exception)
 
 type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
@@ -268,7 +270,8 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token} pn = do
+  tknStr <- deviceToken token
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.randomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
@@ -282,6 +285,9 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token
     else logWarn $ "APNS error: " <> T.pack (show status) <> " " <> reason' <> apnsIds response
   result status reason'
   where
+    deviceToken t = case t of
+      APNSDeviceToken _ dt -> pure dt
+      _ -> throwE PPInvalidPusher
     apnsIds response = headerStr "apns-id" <> headerStr "apns-unique-id"
       where
         headerStr name =
diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs
index 9a201ff2a..6571d9973 100644
--- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs
@@ -126,8 +126,9 @@ insertNtfTknQuery =
   |]
 
 replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
-replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
+replaceNtfToken st NtfTknRec {ntfTknId, token, tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
   withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do
+    let (pp, ppToken) = deviceTokenFields token
     ExceptT $ assertUpdated <$>
       DB.execute
         db
@@ -141,7 +142,7 @@ replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken),
 
 ntfTknToRow :: NtfTknRec -> NtfTknRow
 ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
-  let DeviceToken pp ppToken = token
+  let (pp, ppToken) = deviceTokenFields token
       NtfRegCode regCode = tknRegCode
    in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)
 
@@ -151,7 +152,8 @@ getNtfToken st tknId =
     getNtfToken_ st " WHERE token_id = ?" (Only tknId)
 
 findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec))
-findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) =
+findNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) = do
+  let (pp, ppToken) = deviceTokenFields token
   getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey)
 
 getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec))
@@ -179,7 +181,7 @@ ntfTknQuery =
 
 rowToNtfTkn :: NtfTknRow -> NtfTknRec
 rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)  =
-  let token = DeviceToken pp ppToken
+  let token = deviceToken' pp ppToken
       tknRegCode = NtfRegCode regCode
    in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
@@ -365,8 +367,9 @@ setTknStatusConfirmed st NtfTknRec {ntfTknId} =
     when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed
 
 setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
-setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} =
+setTokenActive st tkn@NtfTknRec {ntfTknId, token} =
   withFastDB' "setTokenActive" st $ \db -> do
+    let (pp, ppToken) = deviceTokenFields token
     updateTknStatus_ st db tkn NTActive
     -- this removes other instances of the same token, e.g. because of repeated token registration attempts
     tknIds <-

From 06e8eb233501ce37d691a5520b704428c7d4e228 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Wed, 9 Jul 2025 15:44:31 +0200
Subject: [PATCH 05/19] Fix tests

---
 tests/AgentTests/FunctionalAPITests.hs | 10 +++++-----
 tests/AgentTests/ServerChoice.hs       |  2 +-
 tests/SMPAgentClient.hs                |  2 +-
 3 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index a3a8d7056..818476ec4 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -957,7 +957,7 @@ testUpdateConnectionUserId :: HasCallStack => IO ()
 testUpdateConnectionUserId =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] [noAuthSrvCfg testNtfServer]
     _ <- changeConnectionUser alice 1 connId newUserId
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
     sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
@@ -2680,7 +2680,7 @@ testUsers =
   withAgentClients2 $ \a b -> runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetings a bId b aId
-    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] [noAuthSrvCfg testNtfServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetings a bId' b aId'
     deleteUser a auId True
@@ -2695,7 +2695,7 @@ testDeleteUserQuietly =
   withAgentClients2 $ \a b -> runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetings a bId b aId
-    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] [noAuthSrvCfg testNtfServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetings a bId' b aId'
     deleteUser a auId False
@@ -2707,7 +2707,7 @@ testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
   (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetings a bId b aId
-    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] [noAuthSrvCfg testNtfServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetings a bId' b aId'
     pure (aId, bId, auId, aId', bId')
@@ -3303,7 +3303,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     ("", "", UP _ _) <- nGet a
     a `hasClients` 1
 
-    aUserId2 <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    aUserId2 <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] [noAuthSrvCfg testNtfServer]
     (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1
     exchangeGreetings a bId2 b aId2
     (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1
diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs
index 12e690888..19aeff397 100644
--- a/tests/AgentTests/ServerChoice.hs
+++ b/tests/AgentTests/ServerChoice.hs
@@ -59,7 +59,7 @@ initServers :: InitialAgentServers
 initServers =
   InitialAgentServers
     { smp = M.fromList [(1, testSMPServers)],
-      ntf = [testNtfServer],
+      ntf = userServers [testNtfServer],
       xftp = userServers [testXFTPServer],
       netCfg = defaultNetworkConfig,
       presetDomains = []
diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs
index 1c256c092..04be561cd 100644
--- a/tests/SMPAgentClient.hs
+++ b/tests/SMPAgentClient.hs
@@ -62,7 +62,7 @@ initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
     { smp = userServers [testSMPServer],
-      ntf = [testNtfServer],
+      ntf = userServers [testNtfServer],
       xftp = userServers [testXFTPServer],
       netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000},
       presetDomains = []

From 7e11a17ee4819716aefea177575c7a8652f810ae Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Fri, 11 Jul 2025 16:48:38 +0200
Subject: [PATCH 06/19] Fix move push

---
 src/Simplex/Messaging/Notifications/Server.hs  |  3 +--
 .../Messaging/Notifications/Server/Push.hs     | 18 ++++++++++++++++++
 .../Notifications/Server/Push/APNS.hs          | 13 -------------
 3 files changed, 19 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 29ac44d4d..38018760c 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -56,8 +56,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Prometheus
-import Simplex.Messaging.Notifications.Server.Push (PushNotification(..))
-import Simplex.Messaging.Notifications.Server.Push.APNS (PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Push (PushNotification(..), PushProviderError(..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf)
 import Simplex.Messaging.Notifications.Server.Store.Postgres
diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs
index 0320b8c51..3c7e57c6a 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push.hs
@@ -30,6 +30,12 @@ import Data.Time.Clock.System
 import qualified Data.X509 as X
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Parsers (defaultJSON)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError)
+import qualified Simplex.Messaging.Crypto as C
+import Network.HTTP.Types (Status)
+import Control.Exception (Exception)
+import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
+import Control.Monad.Except (ExceptT)
 
 data JWTHeader = JWTHeader
   { alg :: Text, -- key algorithm, ES256 for APNS
@@ -79,3 +85,15 @@ data PushNotification
   | -- | PNAlert Text
     PNCheckMessages
   deriving (Show)
+
+data PushProviderError
+  = PPConnection HTTP2ClientError
+  | PPCryptoError C.CryptoError
+  | PPResponseError (Maybe Status) Text
+  | PPTokenInvalid NTInvalidReason
+  | PPRetryLater
+  | PPPermanentError
+  | PPInvalidPusher
+  deriving (Show, Exception)
+
+type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index dc2f54193..b01c68ce0 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -10,7 +10,6 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
-import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -252,18 +251,6 @@ apnsRequest c tkn ntf@APNSNotification {aps} = do
       APNSBackground {} -> "background"
       _ -> "alert"
 
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid NTInvalidReason
-  | PPRetryLater
-  | PPPermanentError
-  | PPInvalidPusher
-  deriving (Show, Exception)
-
-type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
-
 -- this is not a newtype on purpose to have a correct JSON encoding as a record
 data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 

From 0d10a12ae276c7e2bff1a3d2208075ee38e05a62 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Wed, 16 Jul 2025 16:51:39 +0200
Subject: [PATCH 07/19] Prepare webpush requests

---
 simplexmq.cabal                               |  3 +
 src/Simplex/Messaging/Notifications/Server.hs |  1 +
 .../Messaging/Notifications/Server/Env.hs     | 19 ++++-
 .../Messaging/Notifications/Server/Push.hs    |  5 ++
 .../Notifications/Server/Push/WebPush.hs      | 74 +++++++++++++++++++
 5 files changed, 101 insertions(+), 1 deletion(-)
 create mode 100644 src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index f0fbf7c4f..f4d801f91 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -254,6 +254,7 @@ library
               Simplex.Messaging.Notifications.Server.Main
               Simplex.Messaging.Notifications.Server.Prometheus
               Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push.WebPush
               Simplex.Messaging.Notifications.Server.Push
               Simplex.Messaging.Notifications.Server.Push.APNS.Internal
               Simplex.Messaging.Notifications.Server.Stats
@@ -298,6 +299,8 @@ library
     , directory ==1.3.*
     , filepath ==1.4.*
     , hourglass ==0.2.*
+    , http-client ==0.7.*
+    , http-client-tls ==0.3.6.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
     , iproute ==1.7.*
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 38018760c..5bf6de9d8 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -609,6 +609,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
             err e
           PPPermanentError -> err e
           PPInvalidPusher -> err e
+          _ -> err e
       where
         retryDeliver :: IO (Either PushProviderError ())
         retryDeliver = do
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index 2ef02b23f..345530d7d 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -45,6 +45,9 @@ import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, Transport
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
+import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClient)
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
 
 data NtfServerConfig = NtfServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
@@ -148,13 +151,27 @@ newNtfPushServer qSize apnsConfig = do
   pure NtfPushServer {pushQ, pushClients, apnsConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
+newPushClient s pp = do
+  case pp of
+    PPWebPush -> newWPPushClient s
+    _ -> newAPNSPushClient s pp
+
+newAPNSPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
+newAPNSPushClient NtfPushServer {apnsConfig, pushClients} pp = do
   c <- case apnsProviderHost pp of
     Nothing -> pure $ \_ _ -> pure ()
     Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
   atomically $ TM.insert pp c pushClients
   pure c
 
+newWPPushClient :: NtfPushServer -> IO PushProviderClient
+newWPPushClient NtfPushServer {pushClients} = do
+  logDebug "New WP Client requested"
+  manager <- newManager tlsManagerSettings
+  let c = wpPushProviderClient manager
+  atomically $ TM.insert PPWebPush c pushClients
+  pure c
+
 getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 getPushClient s@NtfPushServer {pushClients} pp =
   TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs
index 3c7e57c6a..a2a954b08 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push.hs
@@ -36,6 +36,7 @@ import Network.HTTP.Types (Status)
 import Control.Exception (Exception)
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
 import Control.Monad.Except (ExceptT)
+import GHC.Exception (SomeException)
 
 data JWTHeader = JWTHeader
   { alg :: Text, -- key algorithm, ES256 for APNS
@@ -94,6 +95,10 @@ data PushProviderError
   | PPRetryLater
   | PPPermanentError
   | PPInvalidPusher
+  | PPWPInvalidUrl
+  | PPWPRemovedEndpoint
+  | PPWPRequestTooLong
+  | PPWPOtherError SomeException
   deriving (Show, Exception)
 
 type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
new file mode 100644
index 000000000..6457d2b84
--- /dev/null
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.Messaging.Notifications.Server.Push.WebPush where
+
+import Network.HTTP.Client
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (WPDeviceToken), WPEndpoint (..))
+import Simplex.Messaging.Notifications.Server.Store.Types
+import Simplex.Messaging.Notifications.Server.Push
+import Control.Monad.Except
+import Control.Logger.Simple (logDebug)
+import Simplex.Messaging.Util (tshow)
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
+import Control.Monad.IO.Class (liftIO)
+import Control.Exception ( fromException, SomeException, try )
+import qualified Network.HTTP.Types as N
+
+wpPushProviderClient :: Manager -> PushProviderClient
+wpPushProviderClient mg tkn _ = do
+      e <- B.unpack <$> endpoint tkn
+      r <- liftPPWPError $ parseUrlThrow e
+      logDebug $ "Request to " <> tshow r.host
+      let requestHeaders = [
+            ("TTL", "2592000") -- 30 days
+            , ("Urgency", "High")
+            , ("Content-Encoding", "aes128gcm")
+        -- TODO: topic for pings and interval
+            ]
+      let req = r {
+        method = "POST"
+        , requestHeaders
+        , requestBody = "ping"
+        , redirectCount = 0
+      }
+      _ <- liftPPWPError $ httpNoBody req mg
+      pure ()
+  where
+    endpoint :: NtfTknRec -> ExceptT PushProviderError IO ByteString
+    endpoint NtfTknRec {token} = do
+      case token of
+        WPDeviceToken WPEndpoint{ endpoint = e } -> pure e
+        _ -> fail "Wrong device token"
+
+liftPPWPError :: IO a -> ExceptT PushProviderError IO a
+liftPPWPError = liftPPWPError' toPPWPError
+
+liftPPWPError' :: (SomeException -> PushProviderError) -> IO a -> ExceptT PushProviderError IO a
+liftPPWPError' err a = do
+  res <- liftIO $ try @SomeException a
+  either (throwError . err) return res
+
+toPPWPError :: SomeException -> PushProviderError
+toPPWPError e = case fromException e of
+    Just (InvalidUrlException _ _) -> PPWPInvalidUrl
+    Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String)
+    _ -> PPWPOtherError e
+  where
+    fromStatusCode status reason
+      | status == N.status200 = PPWPRemovedEndpoint
+      | status == N.status410 = PPWPRemovedEndpoint
+      | status == N.status413 = PPWPRequestTooLong
+      | status == N.status429 = PPRetryLater
+      | status >= N.status500 = PPRetryLater
+      | otherwise = PPResponseError (Just status) (tshow reason)

From 611534fc50a476094fc70469b15028b296350bff Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Wed, 16 Jul 2025 18:13:48 +0200
Subject: [PATCH 08/19] Use content of push notif with web push

---
 .../Notifications/Server/Push/WebPush.hs      | 24 +++++++++++++++----
 1 file changed, 19 insertions(+), 5 deletions(-)

diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index 6457d2b84..625113c75 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -13,20 +13,25 @@
 module Simplex.Messaging.Notifications.Server.Push.WebPush where
 
 import Network.HTTP.Client
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (WPDeviceToken), WPEndpoint (..))
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (WPDeviceToken), WPEndpoint (..), encodePNMessages, PNMessageData)
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.Push
 import Control.Monad.Except
 import Control.Logger.Simple (logDebug)
 import Simplex.Messaging.Util (tshow)
 import qualified Data.ByteString.Char8 as B
-import Data.ByteString.Char8 (ByteString)
 import Control.Monad.IO.Class (liftIO)
 import Control.Exception ( fromException, SomeException, try )
 import qualified Network.HTTP.Types as N
+import qualified Data.Aeson as J
+import Data.Aeson ((.=))
+import qualified Data.ByteString.Lazy as BL
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Text.Encoding as T
+import qualified Data.Text as T
 
 wpPushProviderClient :: Manager -> PushProviderClient
-wpPushProviderClient mg tkn _ = do
+wpPushProviderClient mg tkn pn = do
       e <- B.unpack <$> endpoint tkn
       r <- liftPPWPError $ parseUrlThrow e
       logDebug $ "Request to " <> tshow r.host
@@ -39,18 +44,27 @@ wpPushProviderClient mg tkn _ = do
       let req = r {
         method = "POST"
         , requestHeaders
-        , requestBody = "ping"
+        , requestBody = RequestBodyLBS $ encodePN pn
         , redirectCount = 0
       }
       _ <- liftPPWPError $ httpNoBody req mg
       pure ()
   where
-    endpoint :: NtfTknRec -> ExceptT PushProviderError IO ByteString
+    endpoint :: NtfTknRec -> ExceptT PushProviderError IO B.ByteString
     endpoint NtfTknRec {token} = do
       case token of
         WPDeviceToken WPEndpoint{ endpoint = e } -> pure e
         _ -> fail "Wrong device token"
 
+encodePN :: PushNotification -> BL.ByteString
+encodePN pn = J.encode $ case pn of
+    PNVerification code -> J.object [ "verification" .= code ]
+    PNMessage d -> J.object [ "message" .= encodeData d ]
+    PNCheckMessages -> J.object [ "checkMessages" .= True ]
+  where
+    encodeData :: NonEmpty PNMessageData -> String
+    encodeData a = T.unpack . T.decodeUtf8 $ encodePNMessages a
+
 liftPPWPError :: IO a -> ExceptT PushProviderError IO a
 liftPPWPError = liftPPWPError' toPPWPError
 

From e38332553b9a621a47d8955854ab09f4f01ed9b3 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Fri, 18 Jul 2025 10:16:33 +0200
Subject: [PATCH 09/19] Lint liftPPWPError

---
 src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index 625113c75..bdb2745a6 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -69,9 +69,7 @@ liftPPWPError :: IO a -> ExceptT PushProviderError IO a
 liftPPWPError = liftPPWPError' toPPWPError
 
 liftPPWPError' :: (SomeException -> PushProviderError) -> IO a -> ExceptT PushProviderError IO a
-liftPPWPError' err a = do
-  res <- liftIO $ try @SomeException a
-  either (throwError . err) return res
+liftPPWPError' err a = liftIO (try @SomeException a) >>= either (throwError . err) return
 
 toPPWPError :: SomeException -> PushProviderError
 toPPWPError e = case fromException e of

From f9c5063a9dc3b281e03149b1fc84b2c4798dff41 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Fri, 18 Jul 2025 10:17:08 +0200
Subject: [PATCH 10/19] Encrypt wp notifications

---
 simplexmq.cabal                               |   1 +
 src/Simplex/Messaging/Crypto.hs               |  22 +++-
 .../Notifications/Server/Push/WebPush.hs      | 104 +++++++++++++++++-
 3 files changed, 120 insertions(+), 7 deletions(-)

diff --git a/simplexmq.cabal b/simplexmq.cabal
index f4d801f91..3ee94d25f 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -287,6 +287,7 @@ library
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index e3326b98a..8d976d624 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -124,6 +124,7 @@ module Simplex.Messaging.Crypto
     encryptAEAD,
     decryptAEAD,
     encryptAESNoPad,
+    encryptAES128NoPad,
     decryptAESNoPad,
     authTagSize,
     randomAesKey,
@@ -208,7 +209,7 @@ import Control.Exception (Exception)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Except
-import Crypto.Cipher.AES (AES256)
+import Crypto.Cipher.AES (AES256, AES128)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
@@ -892,6 +893,8 @@ data CryptoError
     CERatchetEarlierMessage Word32
   | -- | duplicate message number
     CERatchetDuplicateMessage
+  | -- | unable to decode ecc key
+    CryptoInvalidECCKey CE.CryptoError
   deriving (Eq, Show, Exception)
 
 aesKeySize :: Int
@@ -1018,11 +1021,22 @@ encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag
 encryptAESNoPad key iv = encryptAEADNoPad key iv ""
 {-# INLINE encryptAESNoPad #-}
 
+-- Used to encrypt WebPush notifications
+-- This function requires 12 bytes IV, it does not transform IV.
+encryptAES128NoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAES128NoPad key iv = encryptAEAD128NoPad key iv ""
+{-# INLINE encryptAES128NoPad #-}
+
 encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
 encryptAEADNoPad aesKey ivBytes ad msg = do
   aead <- initAEADGCM aesKey ivBytes
   pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
 
+encryptAEAD128NoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAEAD128NoPad aesKey ivBytes ad msg = do
+  aead <- initAEAD128GCM aesKey ivBytes
+  pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
+
 -- | AEAD-GCM decryption with associated data.
 --
 -- Used as part of double ratchet encryption.
@@ -1122,6 +1136,12 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
   cipher <- AES.cipherInit aesKey
   AES.aeadInit AES.AEAD_GCM cipher ivBytes
 
+-- this function requires 12 bytes IV, it does not transforms IV.
+initAEAD128GCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES128)
+initAEAD128GCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
+  cipher <- AES.cipherInit aesKey
+  AES.aeadInit AES.AEAD_GCM cipher ivBytes
+
 -- | Random AES256 key.
 randomAesKey :: TVar ChaChaDRG -> STM Key
 randomAesKey = fmap Key . randomBytes aesKeySize
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index bdb2745a6..51e571df3 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -9,10 +9,12 @@
 {-# HLINT ignore "Use newtype instead of data" #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Notifications.Server.Push.WebPush where
 
 import Network.HTTP.Client
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (WPDeviceToken), WPEndpoint (..), encodePNMessages, PNMessageData)
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.Push
@@ -25,36 +27,126 @@ import Control.Exception ( fromException, SomeException, try )
 import qualified Network.HTTP.Types as N
 import qualified Data.Aeson as J
 import Data.Aeson ((.=))
+import qualified Data.Binary as Bin
+import qualified Data.Bits as Bits
+import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Lazy as BL
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Text.Encoding as T
 import qualified Data.Text as T
+import Control.Monad.Trans.Except (throwE)
+import Crypto.Hash.Algorithms (SHA256)
+import Crypto.Random (MonadRandom(getRandomBytes))
+import qualified Crypto.Cipher.Types as CT
+import qualified Crypto.Error as CE
+import qualified Crypto.MAC.HMAC as HMAC
+import qualified Crypto.PubKey.ECC.DH as ECDH
+import qualified Crypto.PubKey.ECC.Types as ECC
+import GHC.Base (when)
 
 wpPushProviderClient :: Manager -> PushProviderClient
 wpPushProviderClient mg tkn pn = do
-      e <- B.unpack <$> endpoint tkn
-      r <- liftPPWPError $ parseUrlThrow e
+      e <- endpoint tkn
+      r <- liftPPWPError $ parseUrlThrow $ B.unpack e.endpoint
       logDebug $ "Request to " <> tshow r.host
+      encBody <- body e
       let requestHeaders = [
             ("TTL", "2592000") -- 30 days
             , ("Urgency", "High")
             , ("Content-Encoding", "aes128gcm")
         -- TODO: topic for pings and interval
             ]
-      let req = r {
+          req = r {
         method = "POST"
         , requestHeaders
-        , requestBody = RequestBodyLBS $ encodePN pn
+        , requestBody = RequestBodyBS encBody
         , redirectCount = 0
       }
       _ <- liftPPWPError $ httpNoBody req mg
       pure ()
   where
-    endpoint :: NtfTknRec -> ExceptT PushProviderError IO B.ByteString
+    endpoint :: NtfTknRec -> ExceptT PushProviderError IO WPEndpoint
     endpoint NtfTknRec {token} = do
       case token of
-        WPDeviceToken WPEndpoint{ endpoint = e } -> pure e
+        WPDeviceToken e -> pure e
         _ -> fail "Wrong device token"
+    -- TODO: move to PPIndalidPusher ? WPEndpoint should be invalidated and removed if the key is invalid, but the validation key is never sent
+    body :: WPEndpoint -> ExceptT PushProviderError IO B.ByteString
+    body e = withExceptT PPCryptoError $ wpEncrypt e.auth e.p256dh (BL.toStrict $ encodePN pn)
+
+-- | encrypt :: auth -> key -> clear -> cipher
+-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
+wpEncrypt :: B.ByteString -> B.ByteString -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
+wpEncrypt auth uaPubKS clearT = do
+  salt :: B.ByteString <- liftIO $ getRandomBytes 16
+  asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
+  uaPubK <- point uaPubKS
+  let asPubK = BL.toStrict . uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
+      ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
+      prkKey = hmac auth ecdhSecret
+      keyInfo = "WebPush: info\0" <> uaPubKS <> asPubK
+      ikm = hmac prkKey (keyInfo <> "\x01")
+      prk = hmac salt ikm
+      cekInfo = "Content-Encoding: aes128gcm\0" :: B.ByteString
+      cek = takeHM 16 $ hmac prk (cekInfo <> "\x01")
+      nonceInfo = "Content-Encoding: nonce\0" :: B.ByteString
+      nonce = takeHM 12 $ hmac prk (nonceInfo <> "\x01")
+      rs = BL.toStrict $ Bin.encode (4096 :: Bin.Word32) -- with RFC8291, it's ok to always use 4096 because there is only one single record and the final record can be smaller than rs (RFC8188)
+      idlen = BL.toStrict $ Bin.encode (65 :: Bin.Word8) -- with RFC8291, keyid is the pubkey, so always 65 bytes
+      header = salt <> rs <> idlen <> asPubK
+  iv <- ivFrom nonce
+  -- The last record uses a padding delimiter octet set to the value 0x02
+  (C.AuthTag (CT.AuthTag tag), cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
+  pure $ header <> cipherT <> BA.convert tag
+  where
+    point :: B.ByteString -> ExceptT C.CryptoError IO ECC.Point
+    point s = withExceptT C.CryptoInvalidECCKey $ uncompressDecode $ BL.fromStrict s
+    hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
+    takeHM :: Int -> HMAC.HMAC SHA256 -> B.ByteString
+    takeHM n v = BL.toStrict $ BL.pack $ take n $ BA.unpack v
+    ivFrom :: B.ByteString -> ExceptT C.CryptoError IO C.GCMIV
+    ivFrom s = case C.gcmIV s of
+      Left e -> throwE e
+      Right iv -> pure iv
+
+-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
+-- | as required by RFC8291
+-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
+uncompressEncode :: ECC.Point -> BL.ByteString
+uncompressEncode (ECC.Point x y) = "\x04" <>
+                                     encodeBigInt x <>
+                                     encodeBigInt y
+uncompressEncode ECC.PointO = "\0"
+
+uncompressDecode :: BL.ByteString -> ExceptT CE.CryptoError IO ECC.Point
+uncompressDecode "\0" = pure ECC.PointO
+uncompressDecode s = do
+  when (BL.take 1 s /= prefix) $ throwError CE.CryptoError_PointFormatUnsupported
+  when (BL.length s /= 65) $ throwError CE.CryptoError_KeySizeInvalid
+  let s' = BL.drop 1 s
+  x <- decodeBigInt $ BL.take 32 s'
+  y <- decodeBigInt $ BL.drop 32 s'
+  pure $ ECC.Point x y
+  where
+    prefix = "\x04" :: BL.ByteString
+
+encodeBigInt :: Integer -> BL.ByteString
+encodeBigInt i = do
+  let s1 = Bits.shiftR i 64
+      s2 = Bits.shiftR s1 64
+      s3 = Bits.shiftR s2 64
+  Bin.encode ( w64 s3, w64 s2, w64 s1, w64 i )
+  where
+    w64 :: Integer -> Bin.Word64
+    w64 = fromIntegral
+
+decodeBigInt :: BL.ByteString -> ExceptT CE.CryptoError IO Integer
+decodeBigInt s = do
+  when (BL.length s /= 32) $ throwError CE.CryptoError_PointSizeInvalid
+  let (w3, w2, w1, w0) = Bin.decode s :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64 )
+  pure $ shift 3 w3 + shift 2 w2 + shift 1 w1 + shift 0 w0
+  where
+    shift i w = Bits.shiftL (fromIntegral w) (64*i)
 
 encodePN :: PushNotification -> BL.ByteString
 encodePN pn = J.encode $ case pn of

From 7fd0e27e2fac5479870994cc0bbf3c5d03c23c2b Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 5 Aug 2025 10:51:48 +0200
Subject: [PATCH 11/19] Add function to verify saved ntf token, with
 unencrypted code

---
 src/Simplex/Messaging/Agent.hs | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index e006669ac..61d1a3955 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -96,6 +96,7 @@ module Simplex.Messaging.Agent
     reconnectSMPServer,
     registerNtfToken,
     verifyNtfToken,
+    verifySavedNtfToken,
     checkNtfToken,
     deleteNtfToken,
     getNtfToken,
@@ -585,6 +586,11 @@ verifyNtfToken :: AgentClient -> UserId -> DeviceToken -> C.CbNonce -> ByteStrin
 verifyNtfToken c userId = withAgentEnv c .:. verifyNtfToken' c userId
 {-# INLINE verifyNtfToken #-}
 
+-- | Verify device notifications token
+verifySavedNtfToken :: AgentClient -> UserId -> ByteString -> AE ()
+verifySavedNtfToken c userId = withAgentEnv c . verifySavedNtfToken' c userId
+{-# INLINE verifySavedNtfToken #-}
+
 checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
 checkNtfToken c = withAgentEnv c . checkNtfToken' c
 {-# INLINE checkNtfToken #-}
@@ -2267,6 +2273,19 @@ verifyNtfToken' c userId deviceToken nonce code =
         when (ntfMode == NMInstant) $ initializeNtfSubs c
     _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token"
 
+verifySavedNtfToken' :: AgentClient -> UserId -> ByteString -> AM ()
+verifySavedNtfToken' c userId code =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn@NtfToken {ntfTokenId = Just tknId, ntfMode} -> do
+      let code' = NtfRegCode code
+      toStatus <-
+        withToken c userId tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
+          agentNtfVerifyToken c tknId tkn code'
+      when (toStatus == NTActive) $ do
+        lift $ setCronInterval c tknId tkn
+        when (ntfMode == NMInstant) $ initializeNtfSubs c
+    _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token"
+
 setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' ()
 setCronInterval c tknId tkn = do
   cron <- asks $ ntfCron . config

From f5720a254104d70b33ac1479ffa9d24ba9988b59 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 5 Aug 2025 10:52:04 +0200
Subject: [PATCH 12/19] Add function to delete saved ntf token

---
 src/Simplex/Messaging/Agent.hs | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 61d1a3955..1fc2fc151 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -99,6 +99,7 @@ module Simplex.Messaging.Agent
     verifySavedNtfToken,
     checkNtfToken,
     deleteNtfToken,
+    deleteSavedNtfToken,
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
@@ -599,6 +600,10 @@ deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
 deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 {-# INLINE deleteNtfToken #-}
 
+deleteSavedNtfToken :: AgentClient -> AE ()
+deleteSavedNtfToken c = withAgentEnv c $ deleteSavedNtfToken' c
+{-# INLINE deleteSavedNtfToken #-}
+
 getNtfToken :: AgentClient -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken c = withAgentEnv c $ getNtfToken' c
 {-# INLINE getNtfToken #-}
@@ -2314,6 +2319,14 @@ deleteNtfToken' c deviceToken =
       deleteNtfSubs c NSCSmpDelete
     _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
 
+deleteSavedNtfToken' :: AgentClient -> AM ()
+deleteSavedNtfToken' c =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn -> do
+      deleteToken c tkn
+      deleteNtfSubs c NSCSmpDelete
+    _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
+
 getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken' c =
   withStore' c getSavedNtfToken >>= \case

From 82c3959e3ae585448e131e8adf8c68636ac7a4a7 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 12 Aug 2025 12:18:49 +0200
Subject: [PATCH 13/19] Add vapid pubkey to ntf servers

---
 simplexmq.cabal                               |   1 +
 src/Simplex/FileTransfer/Client.hs            |   2 +-
 src/Simplex/Messaging/Agent/Client.hs         |   2 +-
 .../Messaging/Agent/Store/AgentStore.hs       |  45 ++++----
 .../Agent/Store/SQLite/Migrations/App.hs      |   4 +-
 .../SQLite/Migrations/M20250808_ntf_vapid.hs  |  19 ++++
 src/Simplex/Messaging/Crypto.hs               |  54 +++++++++
 .../Messaging/Notifications/Server/Main.hs    |  32 +++++-
 .../Notifications/Server/Push/APNS.hs         |   2 +-
 .../Notifications/Server/Push/WebPush.hs      |  49 +-------
 src/Simplex/Messaging/Protocol.hs             | 107 ++++++++++++++----
 11 files changed, 218 insertions(+), 99 deletions(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 3ee94d25f..5c3cea524 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -206,6 +206,7 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250808_ntf_vapid
   if !flag(client_library)
       exposed-modules:
           Simplex.FileTransfer.Client.Main
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index de4da07f2..56b4c97f6 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -105,7 +105,7 @@ defaultXFTPClientConfig =
 getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
 getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
-      ProtocolServer _ host port keyHash = srv
+      ProtocolServer _ host port keyHash _ = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
   let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
       http2Config = xftpHTTP2Config tcConfig config
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 13c2defbb..d3761ab78 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -1162,7 +1162,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
           Left e -> throwE e
 
 ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
-ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _) = do
+ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _ _) = do
   isJust socksProxy || (hostMode == HMOnion && any isOnionHost hosts)
   where
     isOnionHost = \case THOnionHost _ -> True; _ -> False
diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
index 30de731a8..407f3ed1d 100644
--- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs
+++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
@@ -1398,15 +1398,15 @@ getSavedNtfToken db = do
     DB.query_
       db
       [sql|
-        SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
+        SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, s.ntf_vapid,
           t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret,
           t.tkn_status, t.tkn_action, t.ntf_mode
         FROM ntf_tokens t
         JOIN ntf_servers s USING (ntf_host, ntf_port)
       |]
   where
-    ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) =
-      let ntfServer = NtfServer host port keyHash
+    ntfToken ((host, port, keyHash, vapid) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) =
+      let ntfServer = NtfServer host port keyHash $ toExtras [("vapid", vapid)]
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
           deviceToken = deviceToken' provider dt
@@ -1488,7 +1488,7 @@ deleteExpiredNtfTokensToDelete db ttl = do
 type NtfTokenToDelete = (Int64, C.APrivateAuthKey, NtfTokenId)
 
 getNextNtfTokenToDelete :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe NtfTokenToDelete))
-getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _) =
+getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _ _) =
   getWorkItem "ntf tkn del" getNtfTknDbId getNtfTknToDelete (markNtfTokenToDeleteFailed_ db)
   where
     getNtfTknDbId :: IO (Maybe Int64)
@@ -1530,11 +1530,11 @@ getPendingDelTknServers db =
     <$> DB.query_
       db
       [sql|
-        SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash
+        SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash, ntf_vapid
         FROM ntf_tokens_to_delete
       |]
   where
-    toNtfServer (host, port, keyHash) = NtfServer host port keyHash
+    toNtfServer (host, port, keyHash, vapid) = NtfServer host port keyHash $ toExtras [("vapid", vapid)]
 
 deleteNtfTokenToDelete :: DB.Connection -> Int64 -> IO ()
 deleteNtfTokenToDelete db tknDbId =
@@ -1548,7 +1548,7 @@ getNtfSubscription db connId =
     DB.query
       db
       [sql|
-        SELECT c.user_id, s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
+        SELECT c.user_id, s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash, ns.ntf_vapid,
           nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action, nsb.ntf_sub_smp_action, nsb.ntf_sub_action_ts
         FROM ntf_subscriptions nsb
         JOIN connections c USING (conn_id)
@@ -1558,9 +1558,9 @@ getNtfSubscription db connId =
       |]
       (Only connId)
   where
-    ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
+    ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash, ntfVapid) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
       let smpServer = SMPServer smpHost smpPort smpKeyHash
-          ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
+          ntfServer = NtfServer ntfHost ntfPort ntfKeyHash $ toExtras [("vapid", ntfVapid)]
           action = case (ntfAction_, smpAction_, actionTs_) of
             (Just ntfAction, Nothing, Just actionTs) -> Just (NSANtf ntfAction, actionTs)
             (Nothing, Just smpAction, Just actionTs) -> Just (NSASMP smpAction, actionTs)
@@ -1569,7 +1569,7 @@ getNtfSubscription db connId =
 
 createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO (Either StoreError ())
 createNtfSubscription db ntfSubscription action = runExceptT $ do
-  let NtfSubscription {connId, smpServer = smpServer@(SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription
+  let NtfSubscription {connId, smpServer = smpServer@(SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _ _), ntfSubId, ntfSubStatus} = ntfSubscription
   smpServerKeyHash_ <- ExceptT $ getServerKeyHash_ db smpServer
   actionTs <- liftIO getCurrentTime
   liftIO $
@@ -1588,7 +1588,7 @@ createNtfSubscription db ntfSubscription action = runExceptT $ do
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
 supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
-supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
+supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _ _), ntfSubId, ntfSubStatus} action = do
   ts <- getCurrentTime
   DB.execute
     db
@@ -1619,7 +1619,7 @@ supervisorUpdateNtfAction db connId action = do
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
 updateNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO ()
-updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action actionTs = do
+updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _ _), ntfSubId, ntfSubStatus} action actionTs = do
   r <- maybeFirstRow fromOnlyBI $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
   forM_ r $ \updatedBySupervisor -> do
     updatedAt <- getCurrentTime
@@ -1682,7 +1682,7 @@ deleteNtfSubscription' db connId = do
   DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
 
 getNextNtfSubNTFActions :: DB.Connection -> NtfServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)])
-getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize =
+getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _ _) ntfBatchSize =
   getWorkItems "ntf NTF" getNtfConnIds getNtfSubAction (markNtfSubActionNtfFailed_ db)
   where
     getNtfConnIds :: IO [ConnId]
@@ -1750,7 +1750,7 @@ getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize
         DB.query
           db
           [sql|
-            SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
+            SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash, s.ntf_vapid,
               ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action
             FROM ntf_subscriptions ns
             JOIN connections c USING (conn_id)
@@ -1760,8 +1760,8 @@ getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize
           (Only connId)
       where
         err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) =
-          let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
+        ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfVapid, ntfQueueId, ntfSubId, ntfSubStatus, action) =
+          let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash $ toExtras [("vapid", ntfVapid)]
               ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
            in (action, ntfSubscription)
 
@@ -1779,7 +1779,7 @@ getActiveNtfToken db =
     DB.query
       db
       [sql|
-        SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
+        SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, s.ntf_vapid,
           t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret,
           t.tkn_status, t.tkn_action, t.ntf_mode
         FROM ntf_tokens t
@@ -1788,8 +1788,8 @@ getActiveNtfToken db =
       |]
       (Only NTActive)
   where
-    ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) =
-      let ntfServer = NtfServer host port keyHash
+    ntfToken ((host, port, keyHash, vapid) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) =
+      let ntfServer = NtfServer host port keyHash $ toExtras [("vapid", vapid)]
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
           deviceToken = deviceToken' provider dt
@@ -1960,17 +1960,18 @@ getServerKeyHash_ db ProtocolServer {host, port, keyHash} = do
     useKeyHash (Only keyHash') = if keyHash /= keyHash' then Just keyHash else Nothing
 
 upsertNtfServer_ :: DB.Connection -> NtfServer -> IO ()
-upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
+upsertNtfServer_ db ProtocolServer {host, port, keyHash, extras} = do
   DB.execute
     db
     [sql|
-      INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (?,?,?)
+      INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash, ntf_vapid) VALUES (?,?,?,?)
       ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET
         ntf_host=excluded.ntf_host,
         ntf_port=excluded.ntf_port,
         ntf_key_hash=excluded.ntf_key_hash;
+        ntf_vapid=excluded.ntf_vapid;
     |]
-    (host, port, keyHash)
+    (host, port, keyHash, getExtra extras "vapid" "")
 
 -- * createRcvConn helpers
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs
index eea7db3ca..e6becbc78 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs
@@ -43,6 +43,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250808_ntf_vapid
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -85,7 +86,8 @@ schemaMigrations =
     ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
     ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
     ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
-    ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
+    ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
+    ("m20250808_ntf_vapid", m20250808_ntf_vapid, Just down_m20250808_ntf_vapid)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs
new file mode 100644
index 000000000..e33dd12c6
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250808_ntf_vapid where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20250808_ntf_vapid :: Query
+m20250808_ntf_vapid =
+  [sql|
+ALTER TABLE ntf_servers ADD COLUMN ntf_vapid TEXT NOT NULL DEFAULT '';
+UPDATE TABLE ntf_servers SET ntf_vapid = '';
+  |]
+
+down_m20250808_ntf_vapid :: Query
+down_m20250808_ntf_vapid =
+  [sql|
+ALTER TABLE ntf_servers DROP COLUMN ntf_vapid TEXT;
+  |]
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 8d976d624..9c982135c 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -83,6 +83,7 @@ module Simplex.Messaging.Crypto
     signatureKeyPair,
     publicToX509,
     encodeASNObj,
+    readECPrivateKey,
 
     -- * key encoding/decoding
     encodePubKey,
@@ -90,6 +91,8 @@ module Simplex.Messaging.Crypto
     encodePrivKey,
     decodePrivKey,
     pubKeyBytes,
+    uncompressEncode,
+    uncompressDecode,
 
     -- * sign/verify
     Signature (..),
@@ -250,6 +253,12 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
+import qualified Crypto.PubKey.ECC.Types as ECC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Binary as Bin
+import qualified Data.Bits as Bits
+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+import qualified Crypto.Store.PKCS8 as PK
 
 -- | Cryptographic algorithms.
 data Algorithm = Ed25519 | Ed448 | X25519 | X448
@@ -1521,3 +1530,48 @@ keyError :: (a, [ASN1]) -> Either String b
 keyError = \case
   (_, []) -> Left "unknown key algorithm"
   _ -> Left "more than one key"
+
+readECPrivateKey :: FilePath -> IO ECDSA.PrivateKey
+readECPrivateKey f = do
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  [PK.Unprotected (PrivKeyEC PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
+  pure ECDSA.PrivateKey {private_curve = ECC.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
+
+-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
+-- | as required by RFC8291
+-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
+uncompressEncode :: ECC.Point -> BL.ByteString
+uncompressEncode (ECC.Point x y) = "\x04" <>
+                                     encodeBigInt x <>
+                                     encodeBigInt y
+uncompressEncode ECC.PointO = "\0"
+
+uncompressDecode :: BL.ByteString -> ExceptT CE.CryptoError IO ECC.Point
+uncompressDecode "\0" = pure ECC.PointO
+uncompressDecode s = do
+  when (BL.take 1 s /= prefix) $ throwError CE.CryptoError_PointFormatUnsupported
+  when (BL.length s /= 65) $ throwError CE.CryptoError_KeySizeInvalid
+  let s' = BL.drop 1 s
+  x <- decodeBigInt $ BL.take 32 s'
+  y <- decodeBigInt $ BL.drop 32 s'
+  pure $ ECC.Point x y
+  where
+    prefix = "\x04" :: BL.ByteString
+
+encodeBigInt :: Integer -> BL.ByteString
+encodeBigInt i = do
+  let s1 = Bits.shiftR i 64
+      s2 = Bits.shiftR s1 64
+      s3 = Bits.shiftR s2 64
+  Bin.encode ( w64 s3, w64 s2, w64 s1, w64 i )
+  where
+    w64 :: Integer -> Bin.Word64
+    w64 = fromIntegral
+
+decodeBigInt :: BL.ByteString -> ExceptT CE.CryptoError IO Integer
+decodeBigInt s = do
+  when (BL.length s /= 32) $ throwError CE.CryptoError_PointSizeInvalid
+  let (w3, w2, w1, w0) = Bin.decode s :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64 )
+  pure $ shift 3 w3 + shift 2 w2 + shift 1 w1 + shift 0 w0
+  where
+    shift i w = Bits.shiftL (fromIntegral w) (64*i)
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index a073eee18..5db8afe01 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -13,7 +13,7 @@ module Simplex.Messaging.Notifications.Server.Main where
 import Control.Logger.Simple (setLogLevel)
 import Control.Monad ((<$!>))
 import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
+import Data.Functor ( ($>), void )
 import Data.Ini (lookupValue, readIniFile)
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
@@ -38,7 +38,7 @@ import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
 import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer, toExtras)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Expiration
@@ -55,6 +55,12 @@ import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
+import System.Process (readCreateProcess, shell)
+import GHC.Base (when)
+import qualified Crypto.PubKey.ECC.Types as ECC
+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+import qualified Crypto.PubKey.ECC.DH as ECDH
+import qualified Data.ByteString.Base64.URL as B64
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =
@@ -145,10 +151,11 @@ ntfServerCLI cfgPath logPath =
       clearDirIfExists logPath
       createDirectoryIfMissing True cfgPath
       createDirectoryIfMissing True logPath
+      vapid <- genVapidKey $ combine cfgPath "vapid.privkey"
       let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
       fp <- createServerX509 cfgPath x509cfg
       let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp) (toExtras [("vapid", vapid)])) Nothing
       T.writeFile iniFile $ iniFileContent host
       putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
       warnCAPrivateKeyFile cfgPath x509cfg
@@ -206,10 +213,11 @@ ntfServerCLI cfgPath logPath =
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
+      vapid <- getVapidKey $ combine cfgPath "vapid.privkey"
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
           cfg@NtfServerConfig {transports} = serverConfig
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp) (toExtras [("vapid", vapid)])) Nothing
       printServiceInfo serverVersion srv
       printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
@@ -387,3 +395,19 @@ cliCommandP cfgPath logPath iniFile =
               <> metavar "FQDN"
           )
       pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn}
+
+genVapidKey :: FilePath -> IO B.ByteString
+genVapidKey file = do
+  cfgExists <- doesFileExist file
+  when (not cfgExists) $ run $ "openssl ecparam -name prime256v1 -genkey -noout -out " <> file
+  privk <- ECDSA.private_d <$> C.readECPrivateKey file
+  pure $ B64.encodeUnpadded . B.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ privk
+  where
+    run cmd = void $ readCreateProcess (shell cmd) ""
+
+getVapidKey :: FilePath -> IO B.ByteString
+getVapidKey file = do
+  cfgExists <- doesFileExist file
+  when (not cfgExists) $ error $ "VAPID key not found: " <> file
+  privk <- ECDSA.private_d <$> C.readECPrivateKey file
+  pure $ B64.encodeUnpadded . B.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ privk
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index b01c68ce0..0747898dc 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -161,7 +161,7 @@ createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
 createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
   https2Client <- newTVarIO Nothing
   void $ connectHTTPS2 apnsHost apnsCfg https2Client
-  privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
+  privateKey <- C.readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
   let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index 51e571df3..eae20fead 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {-# HLINT ignore "Use newtype instead of data" #-}
@@ -28,7 +25,6 @@ import qualified Network.HTTP.Types as N
 import qualified Data.Aeson as J
 import Data.Aeson ((.=))
 import qualified Data.Binary as Bin
-import qualified Data.Bits as Bits
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Lazy as BL
 import Data.List.NonEmpty (NonEmpty)
@@ -38,11 +34,9 @@ import Control.Monad.Trans.Except (throwE)
 import Crypto.Hash.Algorithms (SHA256)
 import Crypto.Random (MonadRandom(getRandomBytes))
 import qualified Crypto.Cipher.Types as CT
-import qualified Crypto.Error as CE
 import qualified Crypto.MAC.HMAC as HMAC
 import qualified Crypto.PubKey.ECC.DH as ECDH
 import qualified Crypto.PubKey.ECC.Types as ECC
-import GHC.Base (when)
 
 wpPushProviderClient :: Manager -> PushProviderClient
 wpPushProviderClient mg tkn pn = do
@@ -81,7 +75,7 @@ wpEncrypt auth uaPubKS clearT = do
   salt :: B.ByteString <- liftIO $ getRandomBytes 16
   asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
   uaPubK <- point uaPubKS
-  let asPubK = BL.toStrict . uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
+  let asPubK = BL.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
       ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
       prkKey = hmac auth ecdhSecret
       keyInfo = "WebPush: info\0" <> uaPubKS <> asPubK
@@ -100,7 +94,7 @@ wpEncrypt auth uaPubKS clearT = do
   pure $ header <> cipherT <> BA.convert tag
   where
     point :: B.ByteString -> ExceptT C.CryptoError IO ECC.Point
-    point s = withExceptT C.CryptoInvalidECCKey $ uncompressDecode $ BL.fromStrict s
+    point s = withExceptT C.CryptoInvalidECCKey $ C.uncompressDecode $ BL.fromStrict s
     hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
     takeHM :: Int -> HMAC.HMAC SHA256 -> B.ByteString
     takeHM n v = BL.toStrict $ BL.pack $ take n $ BA.unpack v
@@ -109,45 +103,6 @@ wpEncrypt auth uaPubKS clearT = do
       Left e -> throwE e
       Right iv -> pure iv
 
--- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
--- | as required by RFC8291
--- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
-uncompressEncode :: ECC.Point -> BL.ByteString
-uncompressEncode (ECC.Point x y) = "\x04" <>
-                                     encodeBigInt x <>
-                                     encodeBigInt y
-uncompressEncode ECC.PointO = "\0"
-
-uncompressDecode :: BL.ByteString -> ExceptT CE.CryptoError IO ECC.Point
-uncompressDecode "\0" = pure ECC.PointO
-uncompressDecode s = do
-  when (BL.take 1 s /= prefix) $ throwError CE.CryptoError_PointFormatUnsupported
-  when (BL.length s /= 65) $ throwError CE.CryptoError_KeySizeInvalid
-  let s' = BL.drop 1 s
-  x <- decodeBigInt $ BL.take 32 s'
-  y <- decodeBigInt $ BL.drop 32 s'
-  pure $ ECC.Point x y
-  where
-    prefix = "\x04" :: BL.ByteString
-
-encodeBigInt :: Integer -> BL.ByteString
-encodeBigInt i = do
-  let s1 = Bits.shiftR i 64
-      s2 = Bits.shiftR s1 64
-      s3 = Bits.shiftR s2 64
-  Bin.encode ( w64 s3, w64 s2, w64 s1, w64 i )
-  where
-    w64 :: Integer -> Bin.Word64
-    w64 = fromIntegral
-
-decodeBigInt :: BL.ByteString -> ExceptT CE.CryptoError IO Integer
-decodeBigInt s = do
-  when (BL.length s /= 32) $ throwError CE.CryptoError_PointSizeInvalid
-  let (w3, w2, w1, w0) = Bin.decode s :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64 )
-  pure $ shift 3 w3 + shift 2 w2 + shift 1 w1 + shift 0 w0
-  where
-    shift i w = Bits.shiftL (fromIntegral w) (64*i)
-
 encodePN :: PushNotification -> BL.ByteString
 encodePN pn = J.encode $ case pn of
     PNVerification code -> J.object [ "verification" .= code ]
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index b52f6e2b4..729e00cf4 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -93,6 +93,8 @@ module Simplex.Messaging.Protocol
     AProtocolType (..),
     ProtocolTypeI (..),
     UserProtocol,
+    Extra,
+    Extras,
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
@@ -175,6 +177,8 @@ module Simplex.Messaging.Protocol
     sameSrvAddr',
     noAuthSrv,
     toMsgInfo,
+    toExtras,
+    getExtra,
 
     -- * TCP transport functions
     TransportBatch (..),
@@ -213,7 +217,7 @@ import Data.Functor (($>))
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
-import Data.Maybe (isJust, isNothing)
+import Data.Maybe (isJust, isNothing, mapMaybe)
 import Data.String
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -968,7 +972,7 @@ instance Encoding ClientMessage where
 type SMPServer = ProtocolServer 'PSMP
 
 pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
-pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
+pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash Nothing
 
 {-# COMPLETE SMPServer #-}
 
@@ -976,8 +980,8 @@ type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
 
 type NtfServer = ProtocolServer 'PNTF
 
-pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
-pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
+pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> Maybe Extras -> ProtocolServer 'PNTF
+pattern NtfServer host port keyHash extras = ProtocolServer SPNTF host port keyHash extras
 
 {-# COMPLETE NtfServer #-}
 
@@ -986,7 +990,7 @@ type NtfServerWithAuth = ProtoServerWithAuth 'PNTF
 type XFTPServer = ProtocolServer 'PXFTP
 
 pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
-pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
+pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash Nothing
 
 {-# COMPLETE XFTPServer #-}
 
@@ -1101,12 +1105,67 @@ userProtocol = \case
   SPNTF -> Just Dict
   -- _ -> Nothing
 
+data Extra = Extra (ByteString, ByteString)
+  deriving (Eq, Ord, Show)
+
+instance Encoding Extra where
+  smpEncode (Extra v) = smpEncode v
+  smpP = do
+    (k, v) <- smpP
+    pure $ Extra (k, v)
+
+instance StrEncoding Extra where
+  strEncode (Extra (k, v)) = k <> "=" <> v
+  strP = do
+    k <- A.takeWhile (/= '=')
+    _ <- A.char '='
+    v <- A.takeByteString
+    pure $ Extra (k, v)
+
+data Extras = Extras [Extra]
+  deriving (Eq, Ord, Show)
+
+instance Encoding Extras where
+  smpEncode (Extras m) = smpEncodeList m
+  smpP = Extras <$> smpListP
+
+instance StrEncoding Extras where
+  strEncode (Extras m) =  B.intercalate "&". map strEncode $ m
+  strP = do
+    m <- listParam `A.sepBy` A.char '&'
+    pure $ Extras m
+    where
+      listParam = parseAll strP <$?> A.takeTill (== '&')
+
+toExtras :: [(ByteString, ByteString)] -> Maybe Extras
+toExtras a = do
+  let l = mapMaybe extra a
+  case length l of
+      0 -> Nothing
+      _ -> Just $ Extras l
+
+  where
+    extra (k, v) = case B.length v of
+        0 -> Nothing
+        _ -> Just $ Extra (k, v)
+
+-- | getExtra :: extras -> key -> default -> value
+getExtra :: Maybe Extras -> ByteString -> ByteString -> ByteString
+getExtra Nothing _ d = d
+getExtra (Just (Extras e)) k d =
+  case filter matchKey e of
+    [] -> d
+    (Extra (_, v)) : _ -> v
+  where
+    matchKey (Extra(k', _)) = k' == k
+
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,
     host :: NonEmpty TransportHost,
     port :: ServiceName,
-    keyHash :: C.KeyHash
+    keyHash :: C.KeyHash,
+    extras :: Maybe Extras
   }
   deriving (Eq, Ord, Show)
 
@@ -1116,15 +1175,15 @@ instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 
 instance ProtocolTypeI p => Encoding (ProtocolServer p) where
-  smpEncode ProtocolServer {host, port, keyHash} =
-    smpEncode (host, port, keyHash)
+  smpEncode ProtocolServer {host, port, keyHash, extras} =
+    smpEncode (host, port, keyHash, extras)
   smpP = do
-    (host, port, keyHash) <- smpP
-    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}
+    (host, port, keyHash, extras) <- smpP
+    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash, extras}
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
-  strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncodeServer scheme (strEncode host) port keyHash Nothing
+  strEncode ProtocolServer {scheme, host, port, keyHash, extras} =
+    strEncodeServer scheme (strEncode host) port keyHash extras Nothing
   strP =
     serverStrP >>= \case
       (AProtocolServer _ srv, Nothing) -> either fail pure $ checkProtocolType srv
@@ -1168,8 +1227,8 @@ data AProtoServerWithAuth = forall p. ProtocolTypeI p => AProtoServerWithAuth (S
 deriving instance Show AProtoServerWithAuth
 
 instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
-  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
-    strEncodeServer scheme (strEncode host) port keyHash auth_
+  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash, extras} auth_) =
+    strEncodeServer scheme (strEncode host) port keyHash extras auth_
   strP = (\(AProtoServerWithAuth _ srv) -> checkProtocolType srv) <$?> strP
 
 instance StrEncoding AProtoServerWithAuth where
@@ -1201,18 +1260,21 @@ legacyEncodeServer ProtocolServer {host, port, keyHash} =
 
 legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
 legacyServerP = do
-  (h, port, keyHash) <- smpP
-  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
+  (h, port, keyHash, extras) <- smpP
+  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash, extras}
 
 legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
-legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
+legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash, extras} =
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash extras Nothing
 
-strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
-strEncodeServer scheme host port keyHash auth_ =
-  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
+strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe Extras -> Maybe BasicAuth -> ByteString
+strEncodeServer scheme host port keyHash extras_ auth_ =
+  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr <> params
   where
     portStr = B.pack $ if null port then "" else ':' : port
+    params = case extras_ of
+      Nothing -> ""
+      Just extras -> "/?" <> strEncode extras
 
 serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
 serverStrP = do
@@ -1221,8 +1283,9 @@ serverStrP = do
   auth_ <- optional $ A.char ':' *> strP
   TransportHosts host <- A.char '@' *> strP
   port <- portP <|> pure ""
+  extras <- optional $ "/?" *> strP
   pure $ case scheme of
-    AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash}, auth_)
+    AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash, extras}, auth_)
   where
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 

From b4fcfeb3530b1375ee381f9e26f6fa2f281c48a5 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Wed, 13 Aug 2025 17:01:40 +0200
Subject: [PATCH 14/19] Send VAPID header with webpush requests

---
 simplexmq.cabal                               |  1 +
 .../Messaging/Notifications/Server/Env.hs     | 21 ++---
 .../Messaging/Notifications/Server/Main.hs    | 30 ++++---
 .../Messaging/Notifications/Server/Push.hs    | 25 ++++--
 .../Notifications/Server/Push/APNS.hs         |  5 +-
 .../Notifications/Server/Push/WebPush.hs      | 79 ++++++++++++++++++-
 tests/NtfClient.hs                            | 10 ++-
 tests/fixtures/vapid.privkey                  |  5 ++
 8 files changed, 141 insertions(+), 35 deletions(-)
 create mode 100644 tests/fixtures/vapid.privkey

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 5c3cea524..f278a8241 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -313,6 +313,7 @@ library
     , network-info ==0.2.*
     , network-transport ==0.5.6
     , network-udp ==0.0.*
+    , network-uri ==2.6.4.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , socks ==0.6.*
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index 345530d7d..94c4a862f 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -45,7 +45,7 @@ import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, Transport
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
-import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClient)
+import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClient, WebPushConfig)
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 
@@ -61,6 +61,7 @@ data NtfServerConfig = NtfServerConfig
     pushQSize :: Natural,
     smpAgentCfg :: SMPClientAgentConfig,
     apnsConfig :: APNSPushClientConfig,
+    wpConfig :: WebPushConfig,
     subsBatchSize :: Int,
     inactiveClientExpiration :: Maybe ExpirationConfig,
     dbStoreConfig :: PostgresStoreCfg,
@@ -98,12 +99,12 @@ data NtfEnv = NtfEnv
   }
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, startOptions} = do
+newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, wpConfig, dbStoreConfig, ntfCredentials, startOptions} = do
   when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
   random <- C.newRandom
   store <- newNtfDbStore dbStoreConfig
   subscriber <- newNtfSubscriber subQSize smpAgentCfg random
-  pushServer <- newNtfPushServer pushQSize apnsConfig
+  pushServer <- newNtfPushServer pushQSize apnsConfig wpConfig
   tlsServerCreds <- loadServerCredential ntfCredentials
   Fingerprint fp <- loadFingerprint ntfCredentials
   serverStats <- newNtfServerStats =<< getCurrentTime
@@ -141,14 +142,15 @@ data SMPSubscriber = SMPSubscriber
 data NtfPushServer = NtfPushServer
   { pushQ :: TBQueue (NtfTknRec, PushNotification),
     pushClients :: TMap PushProvider PushProviderClient,
-    apnsConfig :: APNSPushClientConfig
+    apnsConfig :: APNSPushClientConfig,
+    wpConfig :: WebPushConfig
   }
 
-newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
-newNtfPushServer qSize apnsConfig = do
+newNtfPushServer :: Natural -> APNSPushClientConfig -> WebPushConfig -> IO NtfPushServer
+newNtfPushServer qSize apnsConfig wpConfig = do
   pushQ <- newTBQueueIO qSize
   pushClients <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, apnsConfig}
+  pure NtfPushServer {pushQ, pushClients, apnsConfig, wpConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 newPushClient s pp = do
@@ -165,10 +167,11 @@ newAPNSPushClient NtfPushServer {apnsConfig, pushClients} pp = do
   pure c
 
 newWPPushClient :: NtfPushServer -> IO PushProviderClient
-newWPPushClient NtfPushServer {pushClients} = do
+newWPPushClient NtfPushServer {pushClients, wpConfig} = do
   logDebug "New WP Client requested"
   manager <- newManager tlsManagerSettings
-  let c = wpPushProviderClient manager
+  wpCache <- TM.emptyIO
+  let c = wpPushProviderClient wpConfig wpCache manager
   atomically $ TM.insert PPWebPush c pushClients
   pure c
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index 5db8afe01..65d631ecb 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -57,10 +57,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 import System.Process (readCreateProcess, shell)
 import GHC.Base (when)
-import qualified Crypto.PubKey.ECC.Types as ECC
-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
-import qualified Crypto.PubKey.ECC.DH as ECDH
-import qualified Data.ByteString.Base64.URL as B64
+import Simplex.Messaging.Notifications.Server.Push.WebPush (VapidKey (..), mkVapid, WebPushConfig (..))
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =
@@ -151,11 +148,11 @@ ntfServerCLI cfgPath logPath =
       clearDirIfExists logPath
       createDirectoryIfMissing True cfgPath
       createDirectoryIfMissing True logPath
-      vapid <- genVapidKey $ combine cfgPath "vapid.privkey"
+      VapidKey {fp = vapidFP} <- genVapidKey $ combine cfgPath "vapid.privkey"
       let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
       fp <- createServerX509 cfgPath x509cfg
       let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp) (toExtras [("vapid", vapid)])) Nothing
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp) (toExtras [("vapid", vapidFP)])) Nothing
       T.writeFile iniFile $ iniFileContent host
       putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
       warnCAPrivateKeyFile cfgPath x509cfg
@@ -213,11 +210,11 @@ ntfServerCLI cfgPath logPath =
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
-      vapid <- getVapidKey $ combine cfgPath "vapid.privkey"
+      vapidKey@VapidKey { fp = vapidFP } <- getVapidKey $ combine cfgPath "vapid.privkey"
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@NtfServerConfig {transports} = serverConfig
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp) (toExtras [("vapid", vapid)])) Nothing
+          cfg@NtfServerConfig {transports} = serverConfig vapidKey
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp) (toExtras [("vapid", vapidFP)])) Nothing
       printServiceInfo serverVersion srv
       printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
@@ -232,7 +229,7 @@ ntfServerCLI cfgPath logPath =
               confirmMigrations = MCYesUp,
               deletedTTL = iniDeletedTTL ini
             }
-        serverConfig =
+        serverConfig vapidKey =
           NtfServerConfig
             { transports = iniTransports ini,
               controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
@@ -260,6 +257,7 @@ ntfServerCLI cfgPath logPath =
                     persistErrorInterval = 0 -- seconds
                   },
               apnsConfig = defaultAPNSPushClientConfig,
+              wpConfig = WebPushConfig {vapidKey},
               subsBatchSize = 900,
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
@@ -396,18 +394,18 @@ cliCommandP cfgPath logPath iniFile =
           )
       pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn}
 
-genVapidKey :: FilePath -> IO B.ByteString
+genVapidKey :: FilePath -> IO VapidKey
 genVapidKey file = do
   cfgExists <- doesFileExist file
   when (not cfgExists) $ run $ "openssl ecparam -name prime256v1 -genkey -noout -out " <> file
-  privk <- ECDSA.private_d <$> C.readECPrivateKey file
-  pure $ B64.encodeUnpadded . B.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ privk
+  key <- C.readECPrivateKey file
+  pure $ mkVapid key
   where
     run cmd = void $ readCreateProcess (shell cmd) ""
 
-getVapidKey :: FilePath -> IO B.ByteString
+getVapidKey :: FilePath -> IO VapidKey
 getVapidKey file = do
   cfgExists <- doesFileExist file
   when (not cfgExists) $ error $ "VAPID key not found: " <> file
-  privk <- ECDSA.private_d <$> C.readECPrivateKey file
-  pure $ B64.encodeUnpadded . B.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ privk
+  key <- C.readECPrivateKey file
+  pure $ mkVapid key
diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs
index a2a954b08..1039e5448 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push.hs
@@ -39,14 +39,21 @@ import Control.Monad.Except (ExceptT)
 import GHC.Exception (SomeException)
 
 data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
+  { typ :: Text, -- "JWT"
+    alg :: Text, -- key algorithm, ES256 for APNS
+    kid :: Maybe Text -- key ID
   }
   deriving (Show)
 
+mkJWTHeader :: Text -> Maybe Text -> JWTHeader
+mkJWTHeader alg kid = JWTHeader { typ = "JWT", alg, kid }
+
 data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
+  { iss :: Maybe Text, -- issuer, team ID for APNS
+    iat :: Maybe Int64, -- issue time, seconds from epoch for APNS
+    exp :: Maybe Int64, -- expired time, seconds from epoch for web push
+    aud :: Maybe Text, -- audience, for web push
+    sub :: Maybe Text -- subject, to be inform if there is an issue, for web push
   }
   deriving (Show)
 
@@ -56,7 +63,15 @@ data JWTToken = JWTToken JWTHeader JWTClaims
 mkJWTToken :: JWTHeader -> Text -> IO JWTToken
 mkJWTToken hdr iss = do
   iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
+  pure $ JWTToken hdr $ jwtClaims iat
+  where
+    jwtClaims iat = JWTClaims
+      { iss = Just iss,
+        iat = Just iat,
+        exp = Nothing,
+        aud = Nothing,
+        sub = Nothing
+      }
 
 type SignedJWTToken = ByteString
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index 0747898dc..2af94c896 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -163,7 +163,7 @@ createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, auth
   void $ connectHTTPS2 apnsHost apnsCfg https2Client
   privateKey <- C.readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
-  let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
+  let jwtHeader = mkJWTHeader authKeyAlg (Just authKeyId)
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
   nonceDrg <- C.newRandom
   pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
@@ -179,7 +179,8 @@ getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, token
       atomically $ writeTVar jwtToken t
       pure signedJWT'
   where
-    jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
+    jwtTokenAge (JWTToken _ JWTClaims {iat = Just iat}) = subtract iat . systemSeconds <$> getSystemTime
+    jwtTokenAge (JWTToken _ JWTClaims {iat = Nothing}) = pure maxBound :: IO Int64
 
 mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
 mkApnsJWTToken appTeamId jwtHeader privateKey = do
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index eae20fead..5307202e3 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -37,10 +37,84 @@ import qualified Crypto.Cipher.Types as CT
 import qualified Crypto.MAC.HMAC as HMAC
 import qualified Crypto.PubKey.ECC.DH as ECDH
 import qualified Crypto.PubKey.ECC.Types as ECC
+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+import qualified Data.ByteString.Base64.URL as B64
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import UnliftIO.STM (atomically)
+import Data.Time.Clock.System (getSystemTime, systemSeconds)
+import Data.Int (Int64)
+import Network.URI (URI (..), uriAuthToString)
 
-wpPushProviderClient :: Manager -> PushProviderClient
-wpPushProviderClient mg tkn pn = do
+-- | Vapid
+-- | fp: fingerprint, base64url encoded without padding
+-- | key: privkey
+data VapidKey = VapidKey
+  { key::ECDSA.PrivateKey,
+    fp::B.ByteString
+  }
+  deriving (Eq, Show)
+
+mkVapid :: ECDSA.PrivateKey -> VapidKey
+mkVapid key = VapidKey { key, fp }
+  where
+    fp = B64.encodeUnpadded . B.toStrict . C.uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) . ECDSA.private_d $ key
+
+data WebPushConfig = WebPushConfig
+  { vapidKey :: VapidKey
+  }
+
+data WPCacheEntry = WPCacheEntry
+  { vapidHeader :: B.ByteString,
+    expire :: Int64
+  }
+
+type WPCache = TMap WPEndpoint WPCacheEntry
+
+getVapidHeader :: VapidKey -> WPEndpoint -> WPCache -> IO B.ByteString
+getVapidHeader vapidK e cache = do
+  h <- TM.lookupIO e cache
+  now <- systemSeconds <$> getSystemTime
+  case h of
+    Nothing -> newCacheEntry now
+    Just entry -> if expire entry > now then pure $ vapidHeader entry
+      else newCacheEntry now
+  where
+    newCacheEntry :: Int64 -> IO B.ByteString
+    newCacheEntry now = do
+      -- The new entry expires in one hour
+      let expire = now + 3600
+      vapidHeader <- mkVapidHeader vapidK (endpoint e) expire
+      let entry = WPCacheEntry{ vapidHeader, expire }
+      atomically $ TM.insert e entry cache
+      pure vapidHeader
+
+-- | mkVapidHeader -> vapid -> endpoint -> expire -> vapid header
+mkVapidHeader :: VapidKey -> B.ByteString -> Int64 -> IO B.ByteString
+mkVapidHeader VapidKey {key, fp} endpoint expire = do
+  aud <- Just <$> audience
+  let jwtHeader = mkJWTHeader "ES256" Nothing
+      jwtClaims = JWTClaims
+        { iss = Nothing,
+          iat = Nothing,
+          exp = Just expire,
+          aud,
+          sub = Just "https://github.com/simplex-chat/simplexmq/"
+        }
+      jwt = JWTToken jwtHeader jwtClaims
+  signedToken <- signedJWTToken key jwt
+  pure $ "vapid t=" <> signedToken <> ",k=" <> fp
+  where
+    audience :: IO T.Text
+    audience = do
+      r <- parseUrlThrow . T.unpack . T.decodeUtf8 $ endpoint
+      let uri = getUri r
+      pure . T.pack $ uri.uriScheme <> uriAuthToString id uri.uriAuthority ""
+
+wpPushProviderClient :: WebPushConfig -> WPCache -> Manager -> PushProviderClient
+wpPushProviderClient conf cache mg tkn pn = do
       e <- endpoint tkn
+      vapidH <- liftPPWPError $ getVapidHeader (vapidKey conf) e cache
       r <- liftPPWPError $ parseUrlThrow $ B.unpack e.endpoint
       logDebug $ "Request to " <> tshow r.host
       encBody <- body e
@@ -48,6 +122,7 @@ wpPushProviderClient mg tkn pn = do
             ("TTL", "2592000") -- 30 days
             , ("Urgency", "High")
             , ("Content-Encoding", "aes128gcm")
+            , ("Authorization", vapidH)
         -- TODO: topic for pings and interval
             ]
           req = r {
diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs
index f20264cb8..108d84d57 100644
--- a/tests/NtfClient.hs
+++ b/tests/NtfClient.hs
@@ -60,6 +60,11 @@ import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
+import Simplex.Messaging.Notifications.Server.Push.WebPush (WebPushConfig(..), mkVapid)
+import qualified Crypto.PubKey.ECC.Types as ECC
+import qualified Crypto.PubKey.ECC.DH as ECDH
+import Control.Monad.IO.Unlift (unliftIO)
+import Simplex.Messaging.Notifications.Server.Main (getVapidKey)
 
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
@@ -142,6 +147,9 @@ ntfServerCfg =
           { apnsPort = apnsTestPort,
             caStoreFile = "tests/fixtures/ca.crt"
           },
+      wpConfig = WebPushConfig {
+        vapidKey = getVapidKey "tests/fixtures/vapid.privkey"
+      },
       subsBatchSize = 900,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       dbStoreConfig = ntfTestDBCfg,
@@ -298,7 +306,7 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
 getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
-getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do
+getMockNotification APNSMockServer {notifications} (APNSDeviceToken _ token) = do
   atomically $ TM.lookup token notifications >>= maybe retry readTBQueue
 
 getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest
diff --git a/tests/fixtures/vapid.privkey b/tests/fixtures/vapid.privkey
new file mode 100644
index 000000000..294260c2d
--- /dev/null
+++ b/tests/fixtures/vapid.privkey
@@ -0,0 +1,5 @@
+-----BEGIN EC PRIVATE KEY-----
+MHcCAQEEIMTAncBq2I7G3KvW4C8Y8Heg2cbcDTobbGFQFnBiA5M/oAoGCCqGSM49
+AwEHoUQDQgAEiTsBKQSvUDWslEZcwqLvu0AaPd1Gi5KBl1bpLml57treHt+S93Q5
+hCLHLjKPflQVm3yF31PABCLJsMr8ckvAkA==
+-----END EC PRIVATE KEY-----

From c53ab9d292c9c8ed20cd2cec165e6ec3c77b80cd Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Mon, 18 Aug 2025 09:29:10 +0200
Subject: [PATCH 15/19] Fix DB for vapid

---
 .../Messaging/Agent/Store/AgentStore.hs       |  2 +-
 .../SQLite/Migrations/M20250808_ntf_vapid.hs  |  3 +--
 .../Messaging/Notifications/Server/Main.hs    |  4 +--
 src/Simplex/Messaging/Protocol.hs             | 27 ++++++++++---------
 4 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
index 407f3ed1d..1fc4ca679 100644
--- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs
+++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs
@@ -1971,7 +1971,7 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash, extras} = do
         ntf_key_hash=excluded.ntf_key_hash;
         ntf_vapid=excluded.ntf_vapid;
     |]
-    (host, port, keyHash, getExtra extras "vapid" "")
+    (host, port, keyHash, getExtra extras "vapid")
 
 -- * createRcvConn helpers
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs
index e33dd12c6..bb7e3c3db 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250808_ntf_vapid.hs
@@ -8,8 +8,7 @@ import Database.SQLite.Simple.QQ (sql)
 m20250808_ntf_vapid :: Query
 m20250808_ntf_vapid =
   [sql|
-ALTER TABLE ntf_servers ADD COLUMN ntf_vapid TEXT NOT NULL DEFAULT '';
-UPDATE TABLE ntf_servers SET ntf_vapid = '';
+ALTER TABLE ntf_servers ADD COLUMN ntf_vapid TEXT;
   |]
 
 down_m20250808_ntf_vapid :: Query
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index 65d631ecb..654d64f5c 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -152,7 +152,7 @@ ntfServerCLI cfgPath logPath =
       let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
       fp <- createServerX509 cfgPath x509cfg
       let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp) (toExtras [("vapid", vapidFP)])) Nothing
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp) (toExtras [("vapid", Just vapidFP)])) Nothing
       T.writeFile iniFile $ iniFileContent host
       putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
       warnCAPrivateKeyFile cfgPath x509cfg
@@ -214,7 +214,7 @@ ntfServerCLI cfgPath logPath =
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
           cfg@NtfServerConfig {transports} = serverConfig vapidKey
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp) (toExtras [("vapid", vapidFP)])) Nothing
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp) (toExtras [("vapid", Just vapidFP)])) Nothing
       printServiceInfo serverVersion srv
       printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 729e00cf4..d843353e5 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -229,7 +229,7 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import qualified GHC.TypeLits as TE
 import qualified GHC.TypeLits as Type
 import Network.Socket (ServiceName)
-import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -1137,7 +1137,10 @@ instance StrEncoding Extras where
     where
       listParam = parseAll strP <$?> A.takeTill (== '&')
 
-toExtras :: [(ByteString, ByteString)] -> Maybe Extras
+instance FromField Extras where fromField = blobFieldDecoder strDecode
+instance ToField Extras where toField = toField . Binary . strEncode
+
+toExtras :: [(ByteString, Maybe ByteString)] -> Maybe Extras
 toExtras a = do
   let l = mapMaybe extra a
   case length l of
@@ -1145,17 +1148,17 @@ toExtras a = do
       _ -> Just $ Extras l
 
   where
-    extra (k, v) = case B.length v of
-        0 -> Nothing
-        _ -> Just $ Extra (k, v)
-
--- | getExtra :: extras -> key -> default -> value
-getExtra :: Maybe Extras -> ByteString -> ByteString -> ByteString
-getExtra Nothing _ d = d
-getExtra (Just (Extras e)) k d =
+    extra (k, v) = case v of
+        Nothing -> Nothing
+        Just v' -> Just $ Extra (k, v')
+
+-- | getExtra :: extras -> key -> value
+getExtra :: Maybe Extras -> ByteString -> Maybe ByteString
+getExtra Nothing _ = Nothing
+getExtra (Just (Extras e)) k =
   case filter matchKey e of
-    [] -> d
-    (Extra (_, v)) : _ -> v
+    [] -> Nothing
+    (Extra (_, v)) : _ -> Just v
   where
     matchKey (Extra(k', _)) = k' == k
 

From 88fd5a24374b8d2660abd49c05df214eb4e7ebf7 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Mon, 18 Aug 2025 14:12:37 +0200
Subject: [PATCH 16/19] Fix VAPID signature

---
 src/Simplex/Messaging/Crypto.hs                       |  1 +
 src/Simplex/Messaging/Notifications/Server/Push.hs    | 11 +++++++++++
 .../Messaging/Notifications/Server/Push/WebPush.hs    |  2 +-
 3 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 9c982135c..6c5360372 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -93,6 +93,7 @@ module Simplex.Messaging.Crypto
     pubKeyBytes,
     uncompressEncode,
     uncompressDecode,
+    encodeBigInt,
 
     -- * sign/verify
     Signature (..),
diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs
index 1039e5448..296b686d3 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push.hs
@@ -89,6 +89,17 @@ signedJWTToken pk (JWTToken hdr claims) = do
     jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
     serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
 
+-- | Does it work with APNS ?
+signedJWTTokenRawSign :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTTokenRawSign pk (JWTToken hdr claims) = do
+  let hc = jwtEncode hdr <> "." <> jwtEncode claims
+  sig <- EC.sign pk SHA256 hc
+  pure $ hc <> "." <> serialize sig
+  where
+    jwtEncode :: ToJSON a => a -> ByteString
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ LB.toStrict $ C.encodeBigInt (EC.sign_r sig) <> C.encodeBigInt (EC.sign_s sig)
+
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
   -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index 5307202e3..bd69a2c6b 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -102,7 +102,7 @@ mkVapidHeader VapidKey {key, fp} endpoint expire = do
           sub = Just "https://github.com/simplex-chat/simplexmq/"
         }
       jwt = JWTToken jwtHeader jwtClaims
-  signedToken <- signedJWTToken key jwt
+  signedToken <- signedJWTTokenRawSign key jwt
   pure $ "vapid t=" <> signedToken <> ",k=" <> fp
   where
     audience :: IO T.Text

From 718ace5388bb37a4f50592e93ee24ea7d775077d Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Mon, 18 Aug 2025 14:12:46 +0200
Subject: [PATCH 17/19] Fix Urgency case

---
 src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index bd69a2c6b..8d5367feb 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -120,7 +120,7 @@ wpPushProviderClient conf cache mg tkn pn = do
       encBody <- body e
       let requestHeaders = [
             ("TTL", "2592000") -- 30 days
-            , ("Urgency", "High")
+            , ("Urgency", "high")
             , ("Content-Encoding", "aes128gcm")
             , ("Authorization", vapidH)
         -- TODO: topic for pings and interval

From f28a2052ae88c59653993ca0e409231b5ed00b11 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 19 Aug 2025 10:31:38 +0200
Subject: [PATCH 18/19] Do not smpEncode extras yet

Only ntf servers uses extras, and they aren't passed with smp encoded
strings. smpEncoding was breaking connections to SMP servers
---
 .../Store/SQLite/Migrations/agent_schema.sql    |  1 +
 src/Simplex/Messaging/Protocol.hs               | 17 +++++++++--------
 tests/AgentTests/SQLiteTests.hs                 |  2 +-
 3 files changed, 11 insertions(+), 9 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index fde671d7a..bdf3371e0 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -190,6 +190,7 @@ CREATE TABLE ntf_servers(
   ntf_key_hash BLOB NOT NULL,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  ntf_vapid TEXT,
   PRIMARY KEY(ntf_host, ntf_port)
 ) WITHOUT ROWID;
 CREATE TABLE ntf_tokens(
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index d843353e5..cb5ee48d0 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -1178,11 +1178,12 @@ instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 
 instance ProtocolTypeI p => Encoding (ProtocolServer p) where
-  smpEncode ProtocolServer {host, port, keyHash, extras} =
-    smpEncode (host, port, keyHash, extras)
+  -- extras isn't encoded yet
+  smpEncode ProtocolServer {host, port, keyHash} =
+    smpEncode (host, port, keyHash)
   smpP = do
-    (host, port, keyHash, extras) <- smpP
-    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash, extras}
+    (host, port, keyHash) <- smpP
+    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash, extras = Nothing}
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
   strEncode ProtocolServer {scheme, host, port, keyHash, extras} =
@@ -1263,12 +1264,12 @@ legacyEncodeServer ProtocolServer {host, port, keyHash} =
 
 legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
 legacyServerP = do
-  (h, port, keyHash, extras) <- smpP
-  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash, extras}
+  (h, port, keyHash) <- smpP
+  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash, extras = Nothing}
 
 legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
-legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash, extras} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash extras Nothing
+legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing Nothing
 
 strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe Extras -> Maybe BasicAuth -> ByteString
 strEncodeServer scheme host port keyHash extras_ auth_ =
diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs
index fb6c72996..d88bbca2b 100644
--- a/tests/AgentTests/SQLiteTests.hs
+++ b/tests/AgentTests/SQLiteTests.hs
@@ -698,7 +698,7 @@ testGetPendingServerCommand st = do
     corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
 
 xftpServer1 :: SMP.XFTPServer
-xftpServer1 = SMP.ProtocolServer SMP.SPXFTP "xftp.simplex.im" "5223" testKeyHash
+xftpServer1 = SMP.ProtocolServer SMP.SPXFTP "xftp.simplex.im" "5223" testKeyHash Nothing
 
 rcvFileDescr1 :: FileDescription 'FRecipient
 rcvFileDescr1 =

From 5f527dde3470a700b89fb7dd9c83552cd7a57f45 Mon Sep 17 00:00:00 2001
From: sim <git@sgougeon.fr>
Date: Tue, 19 Aug 2025 17:25:54 +0200
Subject: [PATCH 19/19] Add safety delay for VAPID header expirity

---
 src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
index 8d5367feb..b1f9283f9 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs
@@ -77,7 +77,8 @@ getVapidHeader vapidK e cache = do
   now <- systemSeconds <$> getSystemTime
   case h of
     Nothing -> newCacheEntry now
-    Just entry -> if expire entry > now then pure $ vapidHeader entry
+    -- if it isn't expired, or expire within the next minute
+    Just entry -> if expire entry > now + 60 then pure $ vapidHeader entry
       else newCacheEntry now
   where
     newCacheEntry :: Int64 -> IO B.ByteString