clean up WP encryption

use dependent types for push providers and ntf tokens
refactor
2026-10-12 02:22:45 +00:00 · 2025-11-12 12:46:54 +00:00 · 2025-11-12 10:23:20 +00:00 · 2025-11-11 18:41:20 +00:00 · 2025-11-11 18:16:20 +00:00 · 2025-11-11 17:51:50 +00:00
25 changed files with 886 additions and 198 deletions
@@ -264,7 +264,9 @@ library
              Simplex.Messaging.Notifications.Server.Env
              Simplex.Messaging.Notifications.Server.Main
              Simplex.Messaging.Notifications.Server.Prometheus
+              Simplex.Messaging.Notifications.Server.Push
              Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push.WebPush
              Simplex.Messaging.Notifications.Server.Push.APNS.Internal
              Simplex.Messaging.Notifications.Server.Stats
              Simplex.Messaging.Notifications.Server.Store
@@ -297,6 +299,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.*
@@ -340,6 +343,8 @@ library
        case-insensitive ==1.2.*
      , hashable ==1.4.*
      , ini ==0.4.1
+      , http-client ==0.7.*
+      , http-client-tls ==0.3.6.*
      , optparse-applicative >=0.15 && <0.17
      , process ==1.6.*
      , temporary ==1.3.*
@@ -509,6 +514,7 @@ test-suite simplexmq-test
          AgentTests.NotificationTests
          NtfClient
          NtfServerTests
+          NtfWPTests
          PostgresSchemaDump
  hs-source-dirs:
      tests
@@ -201,7 +201,7 @@ import qualified Simplex.Messaging.Crypto.ShortLink as SL
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (defaultJSON, parse)
 import Simplex.Messaging.Protocol
@@ -619,24 +619,24 @@ reconnectAllServers c = do
  reconnectServerClients c ntfClients

 -- | Register device notifications token
-registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus
 registerNtfToken c = withAgentEnv c .:. registerNtfToken' c
 {-# INLINE registerNtfToken #-}

 -- | Verify device notifications token
-verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AE ()
 verifyNtfToken c = withAgentEnv c .:: verifyNtfToken' c
 {-# INLINE verifyNtfToken #-}

-checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus
+checkNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AE NtfTknStatus
 checkNtfToken c = withAgentEnv c .: checkNtfToken' c
 {-# INLINE checkNtfToken #-}

-deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
+deleteNtfToken :: AgentClient -> ADeviceToken -> AE ()
 deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 {-# INLINE deleteNtfToken #-}

-getNtfToken :: AgentClient -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken :: AgentClient -> AE (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken c = withAgentEnv c $ getNtfToken' c
 {-# INLINE getNtfToken #-}

@@ -2453,7 +2453,7 @@ checkUserServers name srvs =
  unless (any (\ServerCfg {enabled} -> enabled) srvs) $
    logWarn (name <> ": all passed servers are disabled, using all servers.")

-registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
+registerNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AM NtfTknStatus
 registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode =
  withStore' c getSavedNtfToken >>= \case
    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
@@ -2530,7 +2530,7 @@ registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode =
      ns <- asks ntfSupervisor
      atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}

-verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
+verifyNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AM ()
 verifyNtfToken' c nm deviceToken nonce code =
  withStore' c getSavedNtfToken >>= \case
    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
@@ -2549,7 +2549,7 @@ setCronInterval c nm tknId tkn = do
  cron <- asks $ ntfCron . config
  void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c nm tknId tkn cron

-checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
+checkNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AM NtfTknStatus
 checkNtfToken' c nm deviceToken =
  withStore' c getSavedNtfToken >>= \case
    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do
@@ -2563,7 +2563,7 @@ checkNtfToken' c nm deviceToken =
      pure status
    _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token"

-deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
+deleteNtfToken' :: AgentClient -> ADeviceToken -> AM ()
 deleteNtfToken' c deviceToken =
  withStore' c getSavedNtfToken >>= \case
    Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
@@ -2572,7 +2572,7 @@ deleteNtfToken' c deviceToken =
      deleteNtfSubs c NSCSmpDelete
    _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"

-getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken' :: AgentClient -> AM (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 getNtfToken' c =
  withStore' c getSavedNtfToken >>= \case
    Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer)
@@ -1322,7 +1322,7 @@ runNTFServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
        (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
        (dhKey, _) <- atomically $ C.generateKeyPair g
        r <- runExceptT $ do
-          let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
+          let deviceToken = ADT SAPNS $ APNSDeviceToken PPApnsNull "test_ntf_token"
          (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey)
          liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId
        ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf
@@ -1972,7 +1972,7 @@ agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToke
 agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} =
  withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId

-agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
+agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> ADeviceToken -> AM ()
 agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token =
  withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token

@@ -294,7 +294,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 (ADeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceToken', deviceTokenFields)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
@@ -1420,7 +1420,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
@@ -1447,10 +1448,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
@@ -1461,9 +1464,11 @@ 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.Connection -> NtfToken -> ADeviceToken -> IO ()
+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|
@@ -1474,7 +1479,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
@@ -1486,7 +1492,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
@@ -1498,7 +1505,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|
@@ -1823,7 +1831,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} =
@@ -128,6 +128,7 @@ module Simplex.Messaging.Crypto
    encryptAEAD,
    decryptAEAD,
    encryptAESNoPad,
+    encryptAES128NoPad,
    decryptAESNoPad,
    authTagSize,
    randomAesKey,
@@ -210,7 +211,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
@@ -1039,9 +1040,20 @@ 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
+  aead <- initAEADGCM @AES256 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 <- initAEADGCM @AES128 aesKey ivBytes
  pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize

 -- | AEAD-GCM decryption with associated data.
@@ -1063,7 +1075,7 @@ decryptAESNoPad key iv = decryptAEADNoPad key iv ""

 decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
 decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
-  aead <- initAEADGCM aesKey iv
+  aead <- initAEADGCM @AES256 aesKey iv
  maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg tag)

 maxMsgLen :: Int
@@ -1138,7 +1150,7 @@ initAEAD (Key aesKey) (IV ivBytes) = do
    AES.aeadInit AES.AEAD_GCM cipher iv

 -- this function requires 12 bytes IV, it does not transforms IV.
-initAEADGCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES256)
+initAEADGCM :: forall c. AES.BlockCipher c => Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
  cipher <- AES.cipherInit aesKey
  AES.aeadInit AES.AEAD_GCM cipher ivBytes
@@ -43,7 +43,7 @@ ntfCheckToken c nm pKey tknId =
    NRTkn stat -> pure stat
    r -> throwE $ unexpectedResponse r

-ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
+ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ADeviceToken -> ExceptT NtfClientError IO ()
 ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId

 ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -12,6 +13,7 @@
 module Simplex.Messaging.Notifications.Protocol where

 import Control.Applicative (optional, (<|>))
+import qualified Crypto.PubKey.ECC.Types as ECC
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -26,7 +28,7 @@ import Data.Maybe (isNothing)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System
 import Data.Type.Equality
-import Data.Word (Word16)
+import Data.Word (Word16, Word64)
 import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
@@ -35,6 +37,10 @@ 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 qualified Data.ByteString.Lazy as BL
+import qualified Data.Binary as Bin
+import qualified Data.Bits as Bits
+import Network.HTTP.Client (Request, parseUrlThrow)

 data NtfEntity = Token | Subscription
  deriving (Show)
@@ -127,7 +133,7 @@ instance ToJSON NtfRegCode where
  toEncoding = strToJEncoding

 data NewNtfEntity (e :: NtfEntity) where
-  NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
+  NewNtfTkn :: ADeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription

 deriving instance Show (NewNtfEntity e)
@@ -172,7 +178,7 @@ data NtfCommand (e :: NtfEntity) where
  -- | check token status
  TCHK :: NtfCommand 'Token
  -- | replace device token (while keeping all existing subscriptions)
-  TRPL :: DeviceToken -> NtfCommand 'Token
+  TRPL :: ADeviceToken -> NtfCommand 'Token
  -- | delete token - all subscriptions will be removed and no more notifications will be sent
  TDEL :: NtfCommand 'Token
  -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
@@ -372,14 +378,86 @@ instance StrEncoding SMPQueueNtf where
    notifierId <- A.char '/' *> strP
    pure SMPQueueNtf {smpServer, notifierId}

-data PushProvider
+data PushType = APNS | WebPush deriving (Eq, Ord, Show)
+
+data SPushType (p :: PushType) where
+  SAPNS :: SPushType 'APNS
+  SWebPush :: SPushType 'WebPush
+
+toPushType :: SPushType p -> PushType
+toPushType = \case
+  SAPNS -> APNS
+  SWebPush -> WebPush
+
+deriving instance Show (SPushType p)
+
+class PushTypeI (p :: PushType) where sPushType :: SPushType p
+
+instance PushTypeI 'APNS where sPushType = SAPNS
+
+instance PushTypeI 'WebPush where sPushType = SWebPush
+
+instance TestEquality SPushType where
+  testEquality SAPNS SAPNS = Just Refl
+  testEquality SWebPush SWebPush = Just Refl
+  testEquality _ _ = Nothing
+
+checkPushType :: forall t p p'. (PushTypeI p, PushTypeI p') => t p' -> Either String (t p)
+checkPushType c = case testEquality (sPushType @p) (sPushType @p') of
+  Just Refl -> Right c
+  Nothing -> Left "bad push type"
+
+data PushProvider (p :: PushType) where
+  PPAPNS :: APNSProvider -> PushProvider 'APNS
+  PPWP :: WPProvider -> PushProvider 'WebPush
+
+deriving instance Eq (PushProvider p)
+
+deriving instance Ord (PushProvider p)
+
+deriving instance Show (PushProvider p)
+
+data APushProvider = forall p. PushTypeI p => APP (SPushType p) (PushProvider p)
+
+instance Eq APushProvider where
+  APP pt p == APP pt' p' = case testEquality pt pt' of
+    Just Refl -> p == p'
+    Nothing -> False
+
+instance Ord APushProvider where
+  APP pt t `compare` APP pt' t' = case testEquality pt pt' of
+    Just Refl -> t `compare` t'
+    Nothing -> toPushType pt `compare` toPushType pt'
+
+deriving instance Show APushProvider
+
+data APNSProvider
  = PPApnsDev -- provider for Apple development environment
  | 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
  deriving (Eq, Ord, Show)

-instance Encoding PushProvider where
+newtype WPSrvLoc = WPSrvLoc SrvLoc
+  deriving (Eq, Ord, Show)
+
+newtype WPProvider = WPP WPSrvLoc
+  deriving (Eq, Ord, Show)
+
+instance PushTypeI p => Encoding (PushProvider p) where
+  smpEncode = \case
+    PPAPNS p -> smpEncode p
+    PPWP p -> smpEncode p
+  smpP = (\(APP _ p) -> checkPushType p) <$?> smpP
+
+instance Encoding APushProvider where
+  smpEncode (APP _ p) = smpEncode p
+  smpP =
+    A.peekChar' >>= \case
+      'A' -> APP SAPNS . PPAPNS <$> smpP
+      _ -> APP SWebPush . PPWP <$> smpP
+
+instance Encoding APNSProvider where
  smpEncode = \case
    PPApnsDev -> "AD"
    PPApnsProd -> "AP"
@@ -391,9 +469,22 @@ instance Encoding PushProvider where
      "AP" -> pure PPApnsProd
      "AT" -> pure PPApnsTest
      "AN" -> pure PPApnsNull
-      _ -> fail "bad PushProvider"
+      _ -> fail "bad APNSProvider"

-instance StrEncoding PushProvider where
+instance PushTypeI p => StrEncoding (PushProvider p) where
+  strEncode = \case
+    PPAPNS p -> strEncode p
+    PPWP p -> strEncode p
+  strP = (\(APP _ p) -> checkPushType p) <$?> strP
+
+instance StrEncoding APushProvider where
+  strEncode (APP _ p) = strEncode p
+  strP =
+    A.peekChar' >>= \case
+      'a' -> APP SAPNS . PPAPNS <$> strP
+      _ -> APP SWebPush . PPWP <$> strP
+
+instance StrEncoding APNSProvider where
  strEncode = \case
    PPApnsDev -> "apns_dev"
    PPApnsProd -> "apns_prod"
@@ -405,38 +496,251 @@ instance StrEncoding PushProvider where
      "apns_prod" -> pure PPApnsProd
      "apns_test" -> pure PPApnsTest
      "apns_null" -> pure PPApnsNull
-      _ -> fail "bad PushProvider"
+      _ -> fail "bad APNSProvider"

-instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+instance Encoding WPSrvLoc where
+  smpEncode (WPSrvLoc srv) = smpEncode srv
+  smpP = WPSrvLoc <$> smpP

-instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
+instance StrEncoding WPSrvLoc where
+  strEncode (WPSrvLoc srv) = "https://" <> strEncode srv
+  strP = WPSrvLoc <$> ("https://" *> strP)

-data DeviceToken = DeviceToken PushProvider ByteString
+instance Encoding WPProvider where
+  smpEncode (WPP srv) = "WP" <> smpEncode srv
+  smpP = WPP <$> ("WP" *> smpP)
+
+instance StrEncoding WPProvider where
+  strEncode (WPP srv) = "webpush " <> strEncode srv
+  strP = WPP <$> ("webpush " *> strP)
+
+instance FromField APushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField APushProvider where toField = toField . decodeLatin1 . strEncode
+
+newtype WPAuth = WPAuth {unWPAuth :: ByteString} deriving (Eq, Ord, Show)
+
+toWPAuth :: ByteString -> Either String WPAuth
+toWPAuth s
+  | B.length s == 16 = Right $ WPAuth s
+  | otherwise = Left "bad WPAuth"
+
+newtype WPP256dh = WPP256dh ECC.PublicPoint
+  deriving (Eq, Show)
+
+-- This Ord instance for ECC point is quite arbitrary, it is needed because token is used as Map key
+instance Ord WPP256dh where
+  compare (WPP256dh p1) (WPP256dh p2) = case (p1, p2) of
+    (ECC.PointO, ECC.PointO) -> EQ
+    (ECC.PointO, _) -> GT
+    (_, ECC.PointO) -> LT
+    (ECC.Point x1 y1, ECC.Point x2 y2) -> compare (x1, y1) (x2, y2)
+
+data WPKey = WPKey
+  { wpAuth :: WPAuth,
+    wpP256dh :: WPP256dh
+  }
  deriving (Eq, Ord, Show)

-instance Encoding DeviceToken where
-  smpEncode (DeviceToken p t) = smpEncode (p, t)
-  smpP = DeviceToken <$> smpP <*> smpP
+-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
+-- | as required by RFC8291
+-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
+uncompressEncodePoint :: ECC.Point -> ByteString
+uncompressEncodePoint (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y
+uncompressEncodePoint ECC.PointO = "\0"

-instance StrEncoding DeviceToken where
-  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = nullToken <|> hexToken
+uncompressDecodePoint :: ByteString -> Either String ECC.Point
+uncompressDecodePoint "\0" = pure ECC.PointO
+uncompressDecodePoint s
+  | B.null s = Left "KeySizeInvalid"
+  | B.head s /= '\x04' = Left "PointFormatUnsupported"
+  | B.length s /= 65 = Left "KeySizeInvalid"
+  | otherwise = do
+      let s' = B.drop 1 s
+      x <- decodeBigInt $ B.take 32 s'
+      y <- decodeBigInt $ B.drop 32 s'
+      pure $ ECC.Point x y
+
+-- Used to test encryption against the RFC8291 Example - which gives the AS private key
+uncompressDecodePrivateNumber :: ByteString -> Either String ECC.PrivateNumber
+uncompressDecodePrivateNumber s
+  | B.length s /= 32 = Left "KeySizeInvalid"
+  | otherwise = decodeBigInt s
+
+uncompressEncode :: WPP256dh -> ByteString
+uncompressEncode (WPP256dh p) = uncompressEncodePoint p
+
+uncompressDecode :: ByteString -> Either String WPP256dh
+uncompressDecode bs = WPP256dh <$> uncompressDecodePoint bs
+
+encodeBigInt :: Integer -> ByteString
+encodeBigInt i =
+  let s1 = Bits.shiftR i 64
+      s2 = Bits.shiftR s1 64
+      s3 = Bits.shiftR s2 64
+   in BL.toStrict $ Bin.encode (w64 s3, w64 s2, w64 s1, w64 i)
+  where
+    w64 :: Integer -> Word64
+    w64 = fromIntegral
+
+decodeBigInt :: ByteString -> Either String Integer
+decodeBigInt s
+  | B.length s /= 32 = Left "PointSizeInvalid"
+  | otherwise = do
+      let (w3, w2, w1, w0) = Bin.decode (BL.fromStrict s) :: (Word64, Word64, Word64, Word64)
+       in Right $ shift 3 w3 + shift 2 w2 + shift 1 w1 + fromIntegral w0
+  where
+    shift i w = Bits.shiftL (fromIntegral w) (64 * i)
+
+data WPTokenParams = WPTokenParams
+  { wpPath :: ByteString,
+    wpKey :: WPKey
+  }
+  deriving (Eq, Ord, Show)
+
+instance Encoding WPAuth where
+  smpEncode = smpEncode . unWPAuth
+  smpP = toWPAuth <$?> smpP
+
+instance StrEncoding WPAuth where
+  strEncode = strEncode . unWPAuth
+  strP = toWPAuth <$?> strP
+
+instance Encoding WPP256dh where
+  smpEncode p = smpEncode $ uncompressEncode p
+  smpP = uncompressDecode <$?> smpP
+
+instance StrEncoding WPP256dh where
+  strEncode p = strEncode $ uncompressEncode p
+  strP = uncompressDecode <$?> strP
+
+instance Encoding WPKey where
+  smpEncode WPKey {wpAuth, wpP256dh} = smpEncode (wpAuth, wpP256dh)
+  smpP = do
+    wpAuth <- smpP
+    wpP256dh <- smpP
+    pure WPKey {wpAuth, wpP256dh}
+
+instance StrEncoding WPKey where
+  strEncode WPKey {wpAuth, wpP256dh} = strEncode (wpAuth, wpP256dh)
+  strP = do
+    (wpAuth, wpP256dh) <- strP
+    pure WPKey {wpAuth, wpP256dh}
+
+instance Encoding WPTokenParams where
+  smpEncode WPTokenParams {wpPath, wpKey} = smpEncode (wpPath, wpKey)
+  smpP = do
+    wpPath <- smpP
+    wpKey <- smpP
+    pure WPTokenParams {wpPath, wpKey}
+
+instance StrEncoding WPTokenParams where
+  strEncode WPTokenParams {wpPath, wpKey} = wpPath <> " " <> strEncode wpKey
+  strP = do
+    wpPath <- A.takeWhile (/= ' ')
+    _ <- A.char ' '
+    wpKey <- strP
+    pure WPTokenParams {wpPath, wpKey}
+
+data DeviceToken (p :: PushType) where
+  APNSDeviceToken :: APNSProvider -> ByteString -> DeviceToken 'APNS
+  WPDeviceToken :: WPProvider -> WPTokenParams -> DeviceToken 'WebPush
+
+deriving instance Eq (DeviceToken p)
+
+deriving instance Ord (DeviceToken p)
+
+deriving instance Show (DeviceToken p)
+
+data ADeviceToken = forall p. PushTypeI p => ADT (SPushType p) (DeviceToken p)
+
+instance Eq ADeviceToken where
+  ADT p t == ADT p' t' = case testEquality p p' of
+    Just Refl -> t == t'
+    Nothing -> False
+
+instance Ord ADeviceToken where
+  ADT p t `compare` ADT p' t' = case testEquality p p' of
+    Just Refl -> t `compare` t'
+    Nothing -> toPushType p `compare` toPushType p'
+
+deriving instance Show ADeviceToken
+
+tokenPushProvider :: DeviceToken p -> PushProvider p
+tokenPushProvider = \case
+  APNSDeviceToken p _ -> PPAPNS p
+  WPDeviceToken p _ -> PPWP p
+
+instance PushTypeI p => Encoding (DeviceToken p) where
+  smpEncode = \case
+    APNSDeviceToken p t -> smpEncode (p, t)
+    WPDeviceToken p t -> smpEncode (p, t)
+  smpP = (\(ADT _ t) -> checkPushType t) <$?> smpP
+
+instance Encoding ADeviceToken where
+  smpEncode (ADT _ t) = smpEncode t
+  smpP =
+    smpP >>= \case
+      APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> smpP
+      APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> smpP
+
+instance PushTypeI p => StrEncoding (DeviceToken p) where
+  strEncode token = case token of
+    APNSDeviceToken p t -> strEncode p <> " " <> t
+    -- We don't do strEncode (p, t), because we don't want any space between
+    -- p (e.g. webpush https://localhost) and t.wpPath (e.g /random)
+    WPDeviceToken p t -> strEncode p <> strEncode t
+  strP = (\(ADT _ t) -> checkPushType t) <$?> strP
+
+instance StrEncoding ADeviceToken where
+  strEncode (ADT _ t) = strEncode t
+  strP = nullToken <|> deviceToken
    where
-      nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token"
-      hexToken = DeviceToken <$> strP <* A.space <*> hexStringP
-      hexStringP =
+      nullToken = "apns_null test_ntf_token" $> ADT SAPNS (APNSDeviceToken PPApnsNull "test_ntf_token")
+      deviceToken :: A.Parser ADeviceToken
+      deviceToken =
+        strP >>= \case
+          APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> hexStringP
+          APP _ (PPWP p) -> do
+            t <- WPDeviceToken p <$> strP
+            _ <- wpRequest t
+            pure $ ADT SWebPush t
+      hexStringP = do
+        _ <- A.space
        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]
+instance ToJSON (DeviceToken 'APNS) where
+  toEncoding = \case
+    APNSDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= decodeLatin1 t
+  toJSON = \case
+    APNSDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= decodeLatin1 t]

-instance FromJSON DeviceToken where
-  parseJSON = J.withObject "DeviceToken" $ \o -> do
-    pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider"
-    t <- encodeUtf8 <$> o .: "token"
-    pure $ DeviceToken pp t
+instance FromJSON (DeviceToken 'APNS) where
+  parseJSON = J.withObject "DeviceToken" $ \o ->
+    (strDecode @(PushProvider 'APNS) . encodeUtf8 <$?> o .: "pushProvider") >>= \case
+      PPAPNS p -> APNSDeviceToken p . encodeUtf8 <$> (o .: "token")
+
+-- | Returns fields for the device token (pushProvider, token)
+-- TODO [webpush] save token as separate fields
+deviceTokenFields :: ADeviceToken -> (APushProvider, ByteString)
+deviceTokenFields = \case
+  ADT _ (APNSDeviceToken p t) -> (APP SAPNS (PPAPNS p), t)
+  ADT _ (WPDeviceToken p t) -> (APP SWebPush (PPWP p), strEncode t)
+
+-- | Returns the device token from the fields (pushProvider, token)
+-- TODO [webpush] read token as separate fields, don't use `error`
+deviceToken' :: APushProvider -> ByteString -> ADeviceToken
+deviceToken' pp t = case pp of
+  APP _ (PPAPNS p) -> ADT SAPNS $ APNSDeviceToken p t
+  APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> either error id $ strDecode t
+
+wpRequest :: MonadFail m => DeviceToken 'WebPush -> m Request
+wpRequest (WPDeviceToken (WPP s) params) = do
+  let endpoint = strEncode s <> wpPath params
+  case parseUrlThrow $ B.unpack endpoint of
+    Left _ -> fail "Invalid URL"
+    Right r -> pure r

 -- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
 -- because strEncode of NonEmpty list uses comma for separator,
@@ -56,7 +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.APNS (PushNotification (..), 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
@@ -629,18 +629,18 @@ showServer' = decodeLatin1 . strEncode . host

 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
+  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(ADT _ token), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  logDebug $ "sending push notification to " <> tshow (tokenPushProvider token)
  st <- asks store
  case ntf of
    PNVerification _ ->
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
        Right _ -> do
          void $ liftIO $ setTknStatusConfirmed st tkn
          incNtfStatT t ntfVrfDelivered
        Left _ -> incNtfStatT t ntfVrfFailed
    PNCheckMessages -> do
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
        Right _ -> do
          void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime
          incNtfStatT t ntfCronDelivered
@@ -648,7 +648,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
    PNMessage {} -> checkActiveTkn tknStatus $ do
      stats <- asks serverStats
      liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn token ntf) >>= \case
        Left _ -> do
          incNtfStatT t ntfFailed
          liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
@@ -661,10 +661,10 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
    checkActiveTkn status action
      | status == NTActive = action
      | otherwise = liftIO $ logError "bad notification token status"
-    deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
-    deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf = do
+    deliverNotification :: NtfPostgresStore -> NtfTknRec -> DeviceToken p -> PushNotification -> IO (Either PushProviderError ())
+    deliverNotification st tkn@NtfTknRec {ntfTknId} token ntf = do
      deliver <- getPushClient s pp
-      runExceptT (deliver tkn ntf) >>= \case
+      runExceptT (deliver tkn token ntf) >>= \case
        Right _ -> pure $ Right ()
        Left e -> case e of
          PPConnection _ -> retryDeliver
@@ -675,11 +675,13 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
            void $ updateTknStatus st tkn $ NTInvalid $ Just r
            err e
          PPPermanentError -> err e
+          _ -> err e
      where
+        pp = tokenPushProvider token
        retryDeliver :: IO (Either PushProviderError ())
        retryDeliver = do
          deliver <- newPushClient s pp
-          runExceptT (deliver tkn ntf) >>= \case
+          runExceptT (deliver tkn token ntf) >>= \case
            Right _ -> pure $ Right ()
            Left e -> case e of
              PPTokenInvalid r -> do
@@ -904,8 +906,9 @@ withNtfStore stAction continue = do
    Left e -> pure $ NRErr e
    Right a -> continue a

-incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
-incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
+-- TODO [webpush] track webpush statistics separately
+incNtfStatT :: ADeviceToken -> (NtfServerStats -> IORef Int) -> M ()
+incNtfStatT (ADT _ (APNSDeviceToken PPApnsNull _)) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 {-# INLINE incNtfStatT #-}

@@ -25,6 +25,7 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..))
 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)
@@ -45,6 +46,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, ManagerSettings (..), Request (..), Manager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)

 data NtfServerConfig = NtfServerConfig
  { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
@@ -148,27 +152,52 @@ data SMPSubscriber = SMPSubscriber

 data NtfPushServer = NtfPushServer
  { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
-    pushClients :: TMap PushProvider PushProviderClient,
+    apnsPushClients :: TMap APNSProvider (PushProviderClient 'APNS),
+    webPushClients :: TMap WPProvider (PushProviderClient 'WebPush),
    apnsConfig :: APNSPushClientConfig
  }

 newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
 newNtfPushServer qSize apnsConfig = do
  pushQ <- newTBQueueIO qSize
-  pushClients <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, apnsConfig}
+  apnsPushClients <- TM.emptyIO
+  webPushClients <- TM.emptyIO
+  pure NtfPushServer {pushQ, apnsPushClients, webPushClients, apnsConfig}

-newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient 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
+newPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p)
+newPushClient s = \case
+  PPWP p -> newWPPushClient s p
+  PPAPNS p -> newAPNSPushClient s p
+
+newAPNSPushClient :: NtfPushServer -> APNSProvider -> IO (PushProviderClient 'APNS)
+newAPNSPushClient NtfPushServer {apnsConfig, apnsPushClients} pp = case apnsProviderHost pp of
+  Nothing -> pure $ \_ _ _ -> pure ()
+  Just host -> do
+    c <- apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
+    atomically $ TM.insert pp c apnsPushClients
+    pure c
+
+newWPPushClient :: NtfPushServer -> WPProvider -> IO (PushProviderClient 'WebPush)
+newWPPushClient NtfPushServer {webPushClients} pp = do
+  logDebug "New WP Client requested"
+  -- We use one http manager per push server (which may be used by different clients)
+  c <- wpPushProviderClient <$> wpHTTPManager
+  atomically $ TM.insert pp c webPushClients
  pure c

-getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-getPushClient s@NtfPushServer {pushClients} pp =
-  TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
+wpHTTPManager :: IO Manager
+wpHTTPManager = newManager tlsManagerSettings {
+    -- Ideally, we should be able to override the domain resolution to
+    -- disable requests to non-public IPs. The risk is very limited as
+    -- we allow https only, and the body is encrypted. Disabling redirections
+    -- avoids cross-protocol redir (https => http/unix)
+    managerModifyRequest = \r -> pure r {redirectCount = 0}
+  }
+
+getPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p)
+getPushClient s = \case
+  PPAPNS p -> TM.lookupIO p (apnsPushClients s) >>= maybe (newAPNSPushClient s p) pure
+  PPWP p -> TM.lookupIO p (webPushClients s) >>= maybe (newWPPushClient s p) pure

 data NtfRequest
  = NtfReqNew CorrId ANewNtfEntity
@@ -0,0 +1,102 @@
+{-# 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)
+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
+    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 PushProviderError
+  = PPConnection HTTP2ClientError
+  | PPCryptoError C.CryptoError
+  | PPResponseError (Maybe Status) Text
+  | PPTokenInvalid NTInvalidReason
+  | PPRetryLater
+  | PPPermanentError
+  | PPWPInvalidUrl
+  | PPWPRemovedEndpoint
+  | PPWPRequestTooLong
+  | PPWPOtherError Text
+  deriving (Show, Exception)
+
+type PushProviderClient p = NtfTknRec -> DeviceToken p -> PushNotification -> ExceptT PushProviderError IO ()
@@ -1,5 +1,7 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -10,20 +12,13 @@

 module Simplex.Messaging.Notifications.Server.Push.APNS where

-import Control.Exception (Exception)
 import Control.Logger.Simple
 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 +27,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 +45,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 +55,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)

@@ -182,7 +126,7 @@ data APNSPushClientConfig = APNSPushClientConfig
    caStoreFile :: FilePath
  }

-apnsProviderHost :: PushProvider -> Maybe HostName
+apnsProviderHost :: APNSProvider -> Maybe HostName
 apnsProviderHost = \case
  PPApnsNull -> Nothing
  PPApnsTest -> Just "localhost"
@@ -308,24 +252,13 @@ 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
-  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}

 $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)

-apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do
+apnsPushProviderClient :: APNSPushClient -> PushProviderClient 'APNS
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn (APNSDeviceToken _ tknStr) pn = do
  http2 <- liftHTTPS2 $ getApnsHTTP2Client c
  nonce <- atomically $ C.randomCbNonce nonceDrg
  apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
@@ -0,0 +1,120 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use newtype instead of data" #-}
+
+module Simplex.Messaging.Notifications.Server.Push.WebPush where
+
+import Control.Exception (SomeException, fromException, try)
+import Control.Logger.Simple (logDebug)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
+import Crypto.Hash.Algorithms (SHA256)
+import qualified Crypto.MAC.HMAC as HMAC
+import qualified Crypto.PubKey.ECC.DH as ECDH
+import qualified Crypto.PubKey.ECC.Types as ECC
+import Crypto.Random (MonadRandom(getRandomBytes))
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Binary as Bin
+import qualified Data.ByteArray as BA
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import Network.HTTP.Client
+import qualified Network.HTTP.Types as N
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), PushType (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest)
+import Simplex.Messaging.Notifications.Server.Push
+import Simplex.Messaging.Util (liftError', tshow)
+
+wpPushProviderClient :: Manager -> PushProviderClient 'WebPush
+wpPushProviderClient mg _ t@(WPDeviceToken _ params) pn = do
+  -- TODO [webpush] this function should accept type that is restricted to WP token (so, possibly WPProvider and WPTokenParams)
+  -- parsing will happen in DeviceToken parser, so it won't fail here
+  r <- wpRequest t
+  logDebug $ "Web Push request to " <> tshow (host r)
+  encBody <- withExceptT PPCryptoError $ wpEncrypt (wpKey params) (BL.toStrict $ encodeWPN pn)
+  let requestHeaders =
+        [ ("TTL", "2592000"), -- 30 days
+          ("Urgency", "high"),
+          ("Content-Encoding", "aes128gcm")
+    -- TODO: topic for pings and interval
+        ]
+      req =
+        r
+          { method = "POST",
+            requestHeaders,
+            requestBody = RequestBodyBS encBody,
+            redirectCount = 0
+          }
+  void $ liftError' toPPWPError $ try $ httpNoBody req mg
+
+-- | encrypt :: UA key -> clear -> cipher
+-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
+wpEncrypt :: WPKey -> ByteString -> ExceptT C.CryptoError IO ByteString
+wpEncrypt wpKey clearT = do
+  salt :: ByteString <- liftIO $ getRandomBytes 16
+  asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
+  wpEncrypt' wpKey asPrivK salt clearT
+
+-- | encrypt :: UA key -> AS key -> salt -> clear -> cipher
+-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
+wpEncrypt' :: WPKey -> ECC.PrivateNumber -> ByteString -> ByteString -> ExceptT C.CryptoError IO ByteString
+wpEncrypt' WPKey {wpAuth, wpP256dh = WPP256dh uaPubK} asPrivK salt clearT = do
+  let uaPubKS = uncompressEncodePoint $ uaPubK
+  let asPubKS = uncompressEncodePoint . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
+      ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
+      prkKey = hmac (unWPAuth wpAuth) ecdhSecret
+      keyInfo = "WebPush: info\0" <> uaPubKS <> asPubKS
+      ikm = hmac prkKey (keyInfo <> "\x01")
+      prk = hmac salt ikm
+      cekInfo = "Content-Encoding: aes128gcm\0" :: ByteString
+      cek = B.take 16 $ BA.convert $ hmac prk (cekInfo <> "\x01")
+      nonceInfo = "Content-Encoding: nonce\0" :: ByteString
+      nonce = B.take 12 $ BA.convert $ 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 <> asPubKS
+  iv <- ivFrom nonce
+  -- The last record uses a padding delimiter octet set to the value 0x02
+  (C.AuthTag tag, cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
+  -- Uncomment to see intermediate values, to compare with RFC8291 example
+  -- liftIO . print $ strEncode (BA.convert ecdhSecret :: ByteString)
+  -- liftIO . print . strEncode $ takeHM 32 prkKey
+  -- liftIO . print $ strEncode cek
+  -- liftIO . print $ strEncode cipherT
+  pure $ header <> cipherT <> BA.convert tag
+  where
+    hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
+    ivFrom :: ByteString -> ExceptT C.CryptoError IO C.GCMIV
+    ivFrom s = liftEither $ C.gcmIV s
+
+encodeWPN :: PushNotification -> BL.ByteString
+encodeWPN pn = J.encode $ case pn of
+  PNVerification code -> J.object ["verification" .= code]
+  -- This hack prevents sending unencrypted message metadata in notifications, as we do not use it in the client - it simply receives all messages on each notification.
+  -- If we decide to change it to pull model as used in iOS, we can change JSON key to "message" with any payload, as the current clients would interpret it as "checkMessages".
+  -- In this case an additional encryption layer would need to be added here, in the same way as with APNS notifications.
+  PNMessage _ -> J.object ["checkMessages" .= True]
+  PNCheckMessages -> J.object ["checkMessages" .= True]
+
+toPPWPError :: SomeException -> PushProviderError
+toPPWPError e = case fromException e of
+    Just (InvalidUrlException _ _) -> PPWPInvalidUrl
+    Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String)
+    _ -> PPWPOtherError $ tshow 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)
@@ -33,7 +33,7 @@ import Simplex.Messaging.Util (whenM, ($>>=))
 data NtfSTMStore = NtfSTMStore
  { tokens :: TMap NtfTokenId NtfTknData,
    -- multiple registrations exist to protect from malicious registrations if token is compromised
-    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
+    tokenRegistrations :: TMap ADeviceToken (TMap ByteString NtfTokenId),
    subscriptions :: TMap NtfSubscriptionId NtfSubData,
    tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
    subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
@@ -54,7 +54,7 @@ newNtfSTMStore = do

 data NtfTknData = NtfTknData
  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
+    token :: ADeviceToken,
    tknStatus :: TVar NtfTknStatus,
    tknVerifyKey :: NtfPublicAuthKey,
    tknDhKeys :: C.KeyPairX25519,
@@ -12,7 +12,8 @@ import Text.RawString.QQ (r)
 ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
 ntfServerSchemaMigrations =
  [ ("20250417_initial", m20250417_initial, Nothing),
-    ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert)
+    ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert),
+    ("20250916_webpush", m20250916_webpush, Just down_m20250916_webpush)
  ]

 -- | The list of migrations in ascending order by date
@@ -78,7 +79,7 @@ CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token
 CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id);

 CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
-    |]
+  |]

 m20250517_service_cert :: Text
 m20250517_service_cert =
@@ -89,7 +90,7 @@ ALTER TABLE subscriptions ADD COLUMN ntf_service_assoc BOOLEAN NOT NULL DEFAULT

 DROP INDEX idx_subscriptions_smp_server_id_status;
 CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON subscriptions(smp_server_id, ntf_service_assoc, status);
-    |]
+  |]

 down_m20250517_service_cert :: Text
 down_m20250517_service_cert =
@@ -100,4 +101,33 @@ CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_
 ALTER TABLE smp_servers DROP COLUMN ntf_service_id;

 ALTER TABLE subscriptions DROP COLUMN ntf_service_assoc;
-    |]
+  |]
+
+m20250916_webpush :: Text
+m20250916_webpush =
+  [r|
+CREATE TABLE webpush_servers(
+  wp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  wp_host TEXT NOT NULL,
+  wp_port TEXT NOT NULL,
+  wp_keyhash BYTEA NOT NULL
+);
+
+ALTER TABLE tokens
+  ADD COLUMN wp_server_id BIGINT REFERENCES webpush_servers ON DELETE RESTRICT ON UPDATE RESTRICT,
+  ADD COLUMN wp_path TEXT,
+  ADD COLUMN wp_auth BYTEA,
+  ADD COLUMN wp_key BYTEA;
+  |]
+
+down_m20250916_webpush :: Text
+down_m20250916_webpush =
+  [r|
+ALTER TABLE tokens
+  DROP COLUMN wp_server_id,
+  DROP COLUMN wp_path,
+  DROP COLUMN wp_auth,
+  DROP COLUMN wp_key;
+
+DROP TABLE webpush_servers;
+  |]
@@ -128,8 +128,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
@@ -143,7 +144,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)

@@ -153,7 +154,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))
@@ -170,7 +172,7 @@ updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
    void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId)
    withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts

-type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)
+type NtfTknRow = (NtfTokenId, APushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)

 ntfTknQuery :: Query
 ntfTknQuery =
@@ -181,7 +183,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}

@@ -376,8 +378,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 <-
@@ -13,14 +13,14 @@ import Data.Maybe (fromMaybe)
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
 import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..))
 import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey)
 import Simplex.Messaging.SystemTime

 data NtfTknRec = NtfTknRec
  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
+    token :: ADeviceToken,
    tknStatus :: NtfTknStatus,
    tknVerifyKey :: NtfPublicAuthKey,
    tknDhPrivKey :: C.PrivateKeyX25519,
@@ -92,7 +92,31 @@ CREATE TABLE ntf_server.tokens (
    reg_code bytea NOT NULL,
    cron_interval bigint NOT NULL,
    cron_sent_at bigint,
-    updated_at bigint
+    updated_at bigint,
+    wp_server_id bigint,
+    wp_path text,
+    wp_auth bytea,
+    wp_key bytea
+);
+
+
+
+CREATE TABLE ntf_server.webpush_servers (
+    wp_server_id bigint NOT NULL,
+    wp_host text NOT NULL,
+    wp_port text NOT NULL,
+    wp_keyhash bytea NOT NULL
+);
+
+
+
+ALTER TABLE ntf_server.webpush_servers ALTER COLUMN wp_server_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME ntf_server.webpush_servers_wp_server_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
 );


@@ -122,6 +146,11 @@ ALTER TABLE ONLY ntf_server.tokens



+ALTER TABLE ONLY ntf_server.webpush_servers
+    ADD CONSTRAINT webpush_servers_pkey PRIMARY KEY (wp_server_id);
+
+
+
 CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id);


@@ -178,3 +207,8 @@ ALTER TABLE ONLY ntf_server.subscriptions



+ALTER TABLE ONLY ntf_server.tokens
+    ADD CONSTRAINT tokens_wp_server_id_fkey FOREIGN KEY (wp_server_id) REFERENCES ntf_server.webpush_servers(wp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT;
+
+
+
@@ -46,7 +46,7 @@ import System.IO
 data NtfStoreLogRecord
  = CreateToken NtfTknRec
  | TokenStatus NtfTokenId NtfTknStatus
-  | UpdateToken NtfTokenId DeviceToken NtfRegCode
+  | UpdateToken NtfTokenId ADeviceToken NtfRegCode
  | TokenCron NtfTokenId Word16
  | DeleteToken NtfTokenId
  | UpdateTokenTime NtfTokenId SystemDate
@@ -94,7 +94,7 @@ logCreateToken s = logNtfStoreRecord s . CreateToken
 logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
 logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus

-logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
+logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> ADeviceToken -> NtfRegCode -> IO ()
 logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode

 logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
@@ -42,7 +42,7 @@ instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
 instance ToField NtfTknAction where toField = toField . Binary . smpEncode

 data NtfToken = NtfToken
-  { deviceToken :: DeviceToken,
+  { deviceToken :: ADeviceToken,
    ntfServer :: NtfServer,
    ntfTokenId :: Maybe NtfTokenId,
    -- TODO combine keys to key pair as the types should match
@@ -63,7 +63,7 @@ data NtfToken = NtfToken
  }
  deriving (Show)

-newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
+newNtfToken :: ADeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
 newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
  NtfToken
    { deviceToken,
@@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Network.Socket (HostName, ServiceName)
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Encoding (Encoding(..))

 data ServiceScheme = SSSimplex | SSAppServer SrvLoc
  deriving (Eq, Show)
@@ -24,6 +25,12 @@ instance StrEncoding ServiceScheme where
 data SrvLoc = SrvLoc HostName ServiceName
  deriving (Eq, Ord, Show)

+instance Encoding SrvLoc where
+  smpEncode (SrvLoc h s) = smpEncode (h, s)
+  smpP = do
+    (h, s) <- smpP
+    pure $ SrvLoc h s
+
 instance StrEncoding SrvLoc where
  strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port
  strP = SrvLoc <$> host <*> (port <|> pure "")
@@ -196,13 +196,13 @@ testNtfMatrix ps@(_, msType) runTest = do
    cfg' = cfgMS msType
    cfgVPrev' = cfgVPrev msType

-registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken :: AgentClient -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus
 registerNtfToken c = A.registerNtfToken c NRMInteractive

-checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
+checkNtfToken :: AgentClient -> ADeviceToken -> AE NtfTknStatus
 checkNtfToken c = A.checkNtfToken c NRMInteractive

-verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken :: AgentClient -> ADeviceToken -> C.CbNonce -> ByteString -> AE ()
 verifyNtfToken c = A.verifyNtfToken c NRMInteractive

 runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
@@ -218,7 +218,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken apns = do
  withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
      getMockNotification apns tkn
@@ -242,7 +242,7 @@ v .-> key = do
 testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration apns = do
  withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
      getMockNotification apns tkn
@@ -261,7 +261,7 @@ testNtfTokenRepeatRegistration apns = do
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration apns =
  withAgentClients2 $ \a a' -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
      getMockNotification apns tkn
@@ -290,7 +290,7 @@ testNtfTokenSecondRegistration apns =

 testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
    withNtfServer t $ runRight $ do
      NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -311,7 +311,7 @@ testNtfTokenServerRestart t apns = do

 testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverify t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  withAgent 1 agentCfg initAgentServers testDB $ \a -> do
    ntfData <- withNtfServer t $ runRight $ do
      NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -334,7 +334,7 @@ testNtfTokenServerRestartReverify t apns = do

 testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverifyTimeout t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
    (nonce, verification) <- withNtfServer t $ runRight $ do
      NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -355,7 +355,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
          SET tkn_status = ?, tkn_action = ?
          WHERE provider = ? AND device_token = ?
        |]
-        (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString)
+        (NTConfirmed, Just (NTAVerify code), APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString)
    Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
    pure ()
  threadDelay 1500000
@@ -369,7 +369,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do

 testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregister t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  withAgent 1 agentCfg initAgentServers testDB $ \a ->
    withNtfServer t $ runRight $ do
      NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -393,7 +393,7 @@ testNtfTokenServerRestartReregister t apns = do

 testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregisterTimeout t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
    withNtfServer t $ runRight $ do
      NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -409,7 +409,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do
          SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ?
          WHERE provider = ? AND device_token = ?
        |]
-        (NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString)
+        (NTNew, Just NTARegister, APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString)
    Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
    pure ()
  threadDelay 1000000
@@ -434,7 +434,7 @@ getTestNtfTokenPort a =

 testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenMultipleServers t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
  withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
    withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
      withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do
@@ -554,7 +554,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
    get alice ##> ("", bobId, CON)
    get bob ##> ("", aliceId, CON)
    -- register notification token
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken alice tkn NMInstant
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
      getMockNotification apns tkn
@@ -607,9 +607,9 @@ testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> A
 testNotificationSubscriptionNewConnection apns baseId alice bob =
  runRight_ $ do
    -- alice registers notification token
-    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
+    ADT _ APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
    -- bob registers notification token
-    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
+    ADT _ APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
    -- establish connection
    liftIO $ threadDelay 50000
    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -643,9 +643,9 @@ testNotificationSubscriptionNewConnection apns baseId alice bob =
  where
    msgId = subtract baseId

-registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken
+registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO ADeviceToken
 registerTestToken a token mode apns = do
-  let tkn = DeviceToken PPApnsTest token
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest token
  NTRegistered <- registerNtfToken a tkn mode
  Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
    timeout 1000000 $ getMockNotification apns tkn
@@ -1023,7 +1023,7 @@ testMessage_ apns a aId b bId msg = do
  get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
  ackMessage a bId msgId Nothing

-messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
+messageNotification :: HasCallStack => APNSMockServer -> ADeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apns tkn = do
  500000 `timeout` getMockNotification apns tkn >>= \case
    Nothing -> error "no notification"
@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -41,7 +42,7 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost,
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse)
+import Simplex.Messaging.Notifications.Protocol (ADeviceToken (..), DeviceToken (..), NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS
@@ -60,6 +61,7 @@ import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
+import Control.Exception (throwIO)

 testHost :: NonEmpty TransportHost
 testHost = "localhost"
@@ -292,8 +294,9 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
          putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead
          sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"

-getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
-getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do
+getMockNotification :: MonadIO m => APNSMockServer -> ADeviceToken -> m APNSMockRequest
+getMockNotification _ (ADT _ WPDeviceToken {}) = liftIO . throwIO $ userError "Invalid pusher"
+getMockNotification APNSMockServer {notifications} (ADT _ (APNSDeviceToken _ token)) = do
  atomically $ TM.lookup token notifications >>= maybe retry readTBQueue

 getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest
@@ -107,7 +107,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
    (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
    (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
    (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd"
    withAPNSMockServer $ \apns ->
      smpTest2 t msType $ \rh sh ->
        ntfTest t $ \nh -> do
@@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
          (msgBody, "hello") #== "delivered from queue"
          Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
          -- replace token
-          let tkn' = DeviceToken PPApnsTest "efgh"
+          let tkn' = ADT SAPNS $ APNSDeviceToken PPApnsTest "efgh"
          RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
          tId `shouldBe` tId'
          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <-
@@ -237,7 +237,7 @@ registerToken nh apns token = do
  g <- C.newRandom
  (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-  let tkn = DeviceToken PPApnsTest token
+  let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest token
  RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
  APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
    getMockNotification apns tkn
@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
+
+module NtfWPTests where
+
+import Test.Hspec hiding (fit, it)
+import Util
+import Simplex.Messaging.Encoding.String (StrEncoding(..))
+import qualified Data.ByteString as B
+import qualified Crypto.PubKey.ECC.Types as ECC
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push.WebPush (wpEncrypt', encodeWPN)
+import Control.Monad.Except (runExceptT)
+import qualified Data.ByteString.Lazy as BL
+import Simplex.Messaging.Notifications.Server.Push
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Simplex.Messaging.Crypto as C
+import Data.Time.Clock.System (SystemTime(..))
+import Data.Either (isLeft)
+
+ntfWPTests :: Spec
+ntfWPTests = describe "NTF Protocol" $ do
+  it "decode WPDeviceToken from string" testWPDeviceTokenStrEncoding
+  it "decode invalid WPDeviceToken" testInvalidWPDeviceTokenStrEncoding
+  it "Encrypt RFC8291 example" testWPEncryption
+  it "PushNotifications encoding" testPNEncoding
+
+testWPDeviceTokenStrEncoding :: Expectation
+testWPDeviceTokenStrEncoding = do
+  let ts = "webpush https://localhost/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  -- let ts = "apns_null test_ntf_token"
+  -- let ts = "apns_test 11111111222222223333333344444444"
+
+  let auth = either error id $ strDecode "AQ3VfRX3_F38J3ltcmMVRg"
+  let pk = either error id $ strDecode "BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  let params :: WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  wpPath params `shouldBe` "/secret"
+  let key = wpKey params
+  wpAuth key `shouldBe` auth
+  wpP256dh key `shouldBe` pk
+
+  let pp@(WPP s) :: WPProvider = either error id $ strDecode "webpush https://localhost"
+
+  let parsed = either error id $ strDecode ts
+  parsed `shouldBe` WPDeviceToken pp params
+  -- TODO: strEncoding should be base64url _without padding_
+  -- strEncode parsed `shouldBe` ts
+
+  strEncode s <> wpPath params `shouldBe` "https://localhost/secret"
+
+testInvalidWPDeviceTokenStrEncoding :: Expectation
+testInvalidWPDeviceTokenStrEncoding = do
+  -- http-client parser parseUrlThrow is very very lax,
+  -- e.g "https://#1" is a valid URL. But that is the same parser
+  -- we use to send the requests, so that's fine.
+  let ts = "webpush https://localhost:/ AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  let t = strDecode ts :: Either String ADeviceToken
+  t `shouldSatisfy` isLeft
+
+-- | Example from RFC8291
+testWPEncryption :: Expectation
+testWPEncryption = do
+  let clearT :: B.ByteString = "When I grow up, I want to be a watermelon"
+  let pParams :: WPTokenParams = either error id $ strDecode "/push/JzLQ3raZJfFBR0aqvOMsLrt54w4rJUsV BTBZMqHH6r4Tts7J_aSIgg BCVxsr7N_eNgVRqvHtD0zTZsEc6-VV-JvLexhqUzORcxaOzi6-AYWXvTBHm4bjyPjs7Vd8pZGH6SRpkNtoIAiw4"
+  let salt :: B.ByteString = either error id $ strDecode "DGv6ra1nlYgDCS1FRnbzlw"
+  let privBS :: B.ByteString = either error id $ strDecode "yfWPiYE-n46HLnH0KqZOF1fJJU3MYrct3AELtAQ-oRw"
+  asPriv :: ECC.PrivateNumber <- case uncompressDecodePrivateNumber privBS of
+    Left e -> fail $ "Cannot decode PrivateNumber from b64 " <> show e
+    Right p -> pure p
+  mCip <- runExceptT $ wpEncrypt' (wpKey pParams) asPriv salt clearT
+  cipher <- case mCip of
+    Left _ -> fail "Cannot encrypt clear text"
+    Right c -> pure c
+  strEncode cipher `shouldBe` "DGv6ra1nlYgDCS1FRnbzlwAAEABBBP4z9KsN6nGRTbVYI_c7VJSPQTBtkgcy27mlmlMoZIIgDll6e3vCYLocInmYWAmS6TlzAC8wEqKK6PBru3jl7A_yl95bQpu6cVPTpK4Mqgkf1CXztLVBSt2Ks3oZwbuwXPXLWyouBWLVWGNWQexSgSxsj_Qulcy4a-fN"
+
+testPNEncoding :: Expectation
+testPNEncoding = do
+  let pnVerif = PNVerification (NtfRegCode "abcd")
+      pnCheck = PNCheckMessages
+      pnMess = pnM "MyMessage"
+  enc pnCheck `shouldBe` "{\"checkMessages\":true}"
+  enc pnVerif `shouldBe` "{\"verification\":\"YWJjZA==\"}"
+  enc pnMess `shouldBe` "{\"checkMessages\":true}"
+  where
+    enc p = BL.toStrict $ encodeWPN p
+    pnM :: B.ByteString -> PushNotification
+    pnM m = do
+      let smpQ = either error id $ strDecode "smp://AAAA@l/AAAA"
+      let now = MkSystemTime 1761827386 0
+      PNMessage $ PNMessageData smpQ now (C.cbNonce "nonce") m :| []
@@ -45,6 +45,7 @@ import AgentTests.SchemaDump (schemaDumpTest)
 #if defined(dbServerPostgres)
 import NtfServerTests (ntfServerTests)
 import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts)
+import NtfWPTests (ntfWPTests)
 import PostgresSchemaDump (postgresSchemaDumpTest)
 import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
 import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
@@ -139,6 +140,7 @@ main = do
          --   before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
          describe "SMP proxy, postgres-only message store" $
            before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
+        describe "NTF WP tests" ntfWPTests
 #endif
        -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
        describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
Author	SHA1	Message	Date
Evgeny Poberezkin	9384714516	clean up WP encryption	2025-11-12 12:46:54 +00:00
Evgeny Poberezkin	e3f8937412	use dependent types for push providers and ntf tokens	2025-11-12 10:23:20 +00:00
Evgeny Poberezkin	1007deb1f5	refactor	2025-11-11 18:41:20 +00:00
Evgeny Poberezkin	17fe6edcde	instance	2025-11-11 18:16:20 +00:00
Evgeny Poberezkin	4257255de2	fix test	2025-11-11 17:51:50 +00:00
Evgeny Poberezkin	a4931289a7	remove function	2025-11-11 17:39:12 +00:00
Evgeny Poberezkin	673f50e0f4	remove unused error constructor	2025-11-11 17:15:23 +00:00
Evgeny Poberezkin	63c4647f39	refactor	2025-11-11 16:54:38 +00:00
Evgeny Poberezkin	7485175980	remove comment	2025-11-10 21:30:06 +00:00
Evgeny Poberezkin	8ee3fd0ef7	fix migration	2025-11-10 21:14:09 +00:00
S1m	5e28d4faba	[webpush] Parsing during registration (#1661 ) * Parse WPDeviceToken during registration * Clarify PPInvalidPusher with apnsPushProviderClient * Use SrvLoc for webpush endpoints * Remove unused WPEndpoint * Test RFC8291 - webpush encryption - implementation * Fix tests with -fserver_postgres * Disable redirections with webpush * Rename webpush tests, and move behind server_postgres flag * Parse webpush endpoint with StrEncoding * Fix rename webpush tests * Lint import * Test push notification encoding for webpush * Test strDecoding invalid WPDeviceToken	2025-11-10 20:45:16 +00:00
Evgeny Poberezkin	d3d97685c3	Merge branch 'unified-push' into p1gp1g-webpush_requests	2025-11-10 20:23:08 +00:00
Evgeny Poberezkin	f455705974	Merge branch 'master' into unified-push	2025-11-10 20:22:13 +00:00
Evgeny Poberezkin	f5a8d8b21c	token types and migration (WIP, does not compile)	2025-09-16 21:29:38 +01:00
Evgeny Poberezkin	c56b04fb6b	Merge branch 'webpush_requests' of github.com:p1gp1g/simplexmq into p1gp1g-webpush_requests	2025-09-16 19:07:56 +01:00
Evgeny Poberezkin	cf38c129da	Merge branch 'master' into unified-push	2025-09-16 19:02:53 +01:00
Evgeny	4a39c4a021	Merge branch 'unified-push' into webpush_requests	2025-08-29 10:34:03 +01:00
S1mandEvgeny	3e57dda015	ntf server: move token functions and types to shared module to be used with WebPush (#1611 ) * Move generic push functions to Push.hs * Fix move push * minor changes --------- Co-authored-by: Evgeny <[email protected]>	2025-08-29 10:21:40 +01:00
sim	9d30af4edd	Fix Urgency case	2025-08-27 12:47:33 +02:00
sim	720fb40a86	Encrypt wp notifications	2025-08-27 12:47:33 +02:00
sim	1295b28298	Lint liftPPWPError	2025-08-27 12:47:33 +02:00
sim	2205a1fb7c	Use content of push notif with web push	2025-08-27 12:47:33 +02:00
sim	a24024c0b8	Prepare webpush requests	2025-08-27 12:47:33 +02:00
sim	64269c212a	Add WPDeviceToken	2025-08-27 12:47:33 +02:00
sim	e7e7c9bfa1	Rename APNSDeviceToken	2025-08-27 12:47:19 +02:00
sim	c08c3794ba	Fix move push	2025-08-27 12:46:56 +02:00
sim	e90c15bb90	Move generic push functions to Push.hs	2025-08-27 10:33:56 +02:00