[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

simplexmq.cabal

@@ -514,6 +514,7 @@ test-suite simplexmq-test
           AgentTests.NotificationTests
           NtfClient
           NtfServerTests
+          NtfWPTests
           PostgresSchemaDump
   hs-source-dirs:
       tests

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -12,14 +12,13 @@
 module Simplex.Messaging.Notifications.Protocol where
 
 import Control.Applicative (optional, (<|>))
-import Control.Monad
 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
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString as S
 import Data.Functor (($>))
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
@@ -28,7 +27,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 (Word8, Word16)
 import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
@@ -37,6 +36,11 @@ 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 Crypto.Error as CE
+import qualified Data.Bits as Bits
+import Network.HTTP.Client (Request, parseUrlThrow)
 
 data NtfEntity = Token | Subscription
   deriving (Show)
@@ -109,7 +113,7 @@ instance ProtocolMsgTag NtfCmdTag where
 instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
   decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
 
-newtype NtfRegCode = NtfRegCode ByteString
+newtype NtfRegCode = NtfRegCode B.ByteString
   deriving (Eq, Show)
 
 instance Encoding NtfRegCode where
@@ -208,7 +212,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh
     SDEL -> e SDEL_
     PING -> e PING_
     where
-      e :: Encoding a => a -> ByteString
+      e :: Encoding a => a -> B.ByteString
       e = smpEncode
 
   protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
@@ -317,7 +321,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
     NRSub stat -> e (NRSub_, ' ', stat)
     NRPong -> e NRPong_
     where
-      e :: Encoding a => a -> ByteString
+      e :: Encoding a => a -> B.ByteString
       e = smpEncode
 
   protocolP _v = \case
@@ -384,7 +388,10 @@ data APNSProvider
   | PPApnsNull -- used to test servers from the client - does not communicate with APNS
   deriving (Eq, Ord, Show)
 
-newtype WPProvider = WPP (ProtocolServer 'PHTTPS)
+newtype WPSrvLoc = WPSrvLoc SrvLoc
+  deriving (Eq, Ord, Show)
+
+newtype WPProvider = WPP WPSrvLoc
   deriving (Eq, Ord, Show)
 
 instance Encoding PushProvider where
@@ -433,6 +440,14 @@ instance StrEncoding APNSProvider where
       "apns_null" -> pure PPApnsNull
       _ -> fail "bad APNSProvider"
 
+instance Encoding WPSrvLoc where
+  smpEncode (WPSrvLoc srv) = smpEncode srv
+  smpP = WPSrvLoc <$> smpP
+
+instance StrEncoding WPSrvLoc where
+  strEncode (WPSrvLoc srv) = "https://" <> strEncode srv
+  strP = WPSrvLoc <$> ("https://" *> strP)
+
 instance Encoding WPProvider where
   smpEncode (WPP srv) = "WP" <> smpEncode srv
   smpP = WPP <$> ("WP" *> smpP)
@@ -441,64 +456,187 @@ instance StrEncoding WPProvider where
   strEncode (WPP srv) = "webpush " <> strEncode srv
   strP = WPP <$> ("webpush " *> strP)
 
-instance FromField APNSProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
-instance ToField APNSProvider where toField = toField . decodeLatin1 . strEncode
+instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
 
-data WPTokenParams = WPTokenParams
-  { wpPath :: Text, -- parser should validate it's a valid type
-    wpAuth :: ByteString, -- if we enforce size constraints, should also be in parser.
-    wpKey :: WPKey -- or another correct type that is needed for encryption, so it fails in parser and not there
-  }
+tupleToList16
+  :: (a,a,a,a,
+      a,a,a,a,
+      a,a,a,a,
+      a,a,a,a)
+  -> [a]
+tupleToList16
+  (a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15) =
+    [a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15]
 
-newtype WPKey =  WPKey ECC.Point
+listToTuple16
+  :: [a]
+  -> Maybe (a,a,a,a,
+            a,a,a,a,
+            a,a,a,a,
+            a,a,a,a)
+listToTuple16
+  [a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15] =
+    Just (a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15)
+listToTuple16 _ = Nothing
 
-data WPEndpoint = WPEndpoint
-  { endpoint :: ByteString,
-    auth :: ByteString,
-    p256dh :: ByteString
+newtype Auth = Auth (Word8, Word8, Word8, Word8,
+                     Word8, Word8, Word8, Word8,
+                     Word8, Word8, Word8, Word8,
+                     Word8, Word8, Word8, Word8)
+
+instance Eq Auth where
+  (Auth t1) == (Auth t2) = tupleToList16 t1 == tupleToList16 t2
+
+instance Ord Auth where
+  compare (Auth t1) (Auth t2) = compare (tupleToList16 t1) (tupleToList16 t2)
+
+instance Show Auth where
+  show (Auth t) = "Auth " ++ show (tupleToList16 t)
+
+authFromByteString :: S.ByteString -> Maybe Auth
+authFromByteString bs = do
+  tup <- listToTuple16 $ S.unpack bs
+  pure (Auth tup)
+
+authToByteString :: Auth -> S.ByteString
+authToByteString (Auth a) = S.pack $ tupleToList16 a
+
+newtype WPP256dh = WPP256dh ECC.PublicPoint
+  deriving (Eq, Show)
+
+instance Ord WPP256dh where
+  compare (WPP256dh p1) (WPP256dh p2) = comparePt p1 p2
+    where
+      comparePt ECC.PointO ECC.PointO = EQ
+      comparePt ECC.PointO (ECC.Point _ _) = LT
+      comparePt (ECC.Point _ _) ECC.PointO = GT
+      comparePt (ECC.Point x1 y1)  (ECC.Point x2 y2) = compare (x1, y1) (x2, y2)
+
+data WPKey = WPKey
+  { wpAuth :: Auth,
+    wpP256dh :: WPP256dh
   }
   deriving (Eq, Ord, Show)
 
-instance Encoding WPEndpoint where
-  smpEncode WPEndpoint {endpoint, auth, p256dh} = smpEncode (endpoint, auth, p256dh)
+-- | 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 -> BL.ByteString
+uncompressEncodePoint (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y
+uncompressEncodePoint ECC.PointO = "\0"
+
+uncompressDecodePoint :: BL.ByteString -> Either CE.CryptoError ECC.Point
+uncompressDecodePoint "\0" = pure ECC.PointO
+uncompressDecodePoint s
+  | BL.take 1 s /= prefix = Left CE.CryptoError_PointFormatUnsupported
+  | BL.length s /= 65 = Left CE.CryptoError_KeySizeInvalid
+  | otherwise = do
+    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
+
+-- Used to test encryption against the RFC8291 Example - which gives the AS private key
+uncompressDecodePrivateNumber :: BL.ByteString -> Either CE.CryptoError ECC.PrivateNumber
+uncompressDecodePrivateNumber s
+  | BL.length s /= 32 = Left CE.CryptoError_KeySizeInvalid
+  | otherwise = do
+    decodeBigInt s
+
+uncompressEncode :: WPP256dh -> BL.ByteString
+uncompressEncode (WPP256dh p) = uncompressEncodePoint p
+
+uncompressDecode :: BL.ByteString -> Either CE.CryptoError WPP256dh
+uncompressDecode bs = WPP256dh <$> uncompressDecodePoint bs
+
+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 -> Either CE.CryptoError Integer
+decodeBigInt s
+  | BL.length s /= 32 = Left CE.CryptoError_PointSizeInvalid
+  | otherwise = do
+      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)
+
+data WPTokenParams = WPTokenParams
+  { wpPath :: B.ByteString,
+    wpKey :: WPKey
+  }
+  deriving (Eq, Ord, Show)
+
+instance Encoding Auth where
+  smpEncode a = smpEncode $ authToByteString a
+  smpP = smpP >>= \bs ->
+    case authFromByteString bs of
+      Nothing -> fail "Invalid auth"
+      Just a -> pure a
+
+instance StrEncoding Auth where
+  strEncode a = strEncode $ authToByteString a
+  strP = strP >>= \bs ->
+    case authFromByteString bs of
+      Nothing -> fail "Invalid auth"
+      Just a -> pure a
+
+instance Encoding WPP256dh where
+  smpEncode p = smpEncode . BL.toStrict $ uncompressEncode p
+  smpP = smpP >>= \bs ->
+    case uncompressDecode (BL.fromStrict bs) of
+      Left _ -> fail "Invalid p256dh key"
+      Right res -> pure res
+
+instance StrEncoding WPP256dh where
+  strEncode p = strEncode . BL.toStrict $ uncompressEncode p
+  strP = strP >>= \bs ->
+    case uncompressDecode (BL.fromStrict bs) of
+      Left _ -> fail "Invalid p256dh key"
+      Right res -> pure res
+
+instance Encoding WPKey where
+  smpEncode WPKey {wpAuth, wpP256dh} = smpEncode (wpAuth, wpP256dh)
   smpP = do
-    endpoint <- smpP
-    auth <- smpP
-    p256dh <- smpP
-    pure WPEndpoint {endpoint, auth, p256dh}
+    wpAuth <- smpP
+    wpP256dh <- smpP
+    pure WPKey {wpAuth, wpP256dh}
 
-instance StrEncoding WPEndpoint where
-  strEncode WPEndpoint {endpoint, auth, p256dh} = endpoint <> " " <> strEncode auth <> " " <> strEncode p256dh
+instance StrEncoding WPKey where
+  strEncode WPKey {wpAuth, wpP256dh} = strEncode (wpAuth, wpP256dh)
   strP = do
-    endpoint <- A.takeWhile (/= ' ')
+    (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 ' '
-    (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"
-    -- TODO [webpush] parse it here (or rather in WPTokenParams)
-    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}
+    wpKey <- strP
+    pure WPTokenParams {wpPath, wpKey}
 
 data DeviceToken
-  = APNSDeviceToken APNSProvider ByteString
-  | WPDeviceToken WPProvider WPEndpoint
-  -- TODO [webpush] replace with WPTokenParams
-  -- | WPDeviceToken WPProvider WPTokenParams
+  = APNSDeviceToken APNSProvider B.ByteString
+  | WPDeviceToken WPProvider WPTokenParams
   deriving (Eq, Ord, Show)
 
 instance Encoding DeviceToken where
@@ -513,50 +651,67 @@ instance Encoding DeviceToken where
 instance StrEncoding DeviceToken where
   strEncode token = case token of
     APNSDeviceToken p t -> strEncode p <> " " <> t
-    WPDeviceToken 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 = nullToken <|> deviceToken
     where
       nullToken = "apns_null test_ntf_token" $> APNSDeviceToken PPApnsNull "test_ntf_token"
       deviceToken =
-        strP_ >>= \case
+        strP >>= \case
           PPAPNS p -> APNSDeviceToken p <$> hexStringP
-          PPWP p -> WPDeviceToken p <$> strP
-      hexStringP =
+          PPWP p -> do
+            t <- WPDeviceToken p <$> strP
+            _ <- wpRequest t
+            pure 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"
 
--- TODO [webpush] is it needed?
 instance ToJSON DeviceToken where
   toEncoding token = case token of
     APNSDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= decodeLatin1 t
-    WPDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= toJSON t
+    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
+    WPDeviceToken p _ -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p)
+    -- WPDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= toJSON t
   toJSON token = case token of
     APNSDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= decodeLatin1 t]
-    WPDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= toJSON t]
+    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
+    WPDeviceToken p _ -> J.object ["pushProvider" .= decodeLatin1 (strEncode p)]
+    -- WPDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= toJSON t]
 
 instance FromJSON DeviceToken where
   parseJSON = J.withObject "DeviceToken" $ \o ->
     (strDecode . encodeUtf8 <$?> o .: "pushProvider") >>= \case
       PPAPNS p -> APNSDeviceToken p . encodeUtf8 <$> (o .: "token")
-      PPWP p -> WPDeviceToken p <$> (o .: "token")
+      PPWP _ -> fail "FromJSON not implemented for WPDeviceToken"
 
 -- | Returns fields for the device token (pushProvider, token)
 -- TODO [webpush] save token as separate fields
-deviceTokenFields :: DeviceToken -> (PushProvider, ByteString)
+deviceTokenFields :: DeviceToken -> (PushProvider, B.ByteString)
 deviceTokenFields dt = case dt of
   APNSDeviceToken p t -> (PPAPNS p, t)
   WPDeviceToken p t -> (PPWP p, strEncode t)
 
 -- | Returns the device token from the fields (pushProvider, token)
-deviceToken' :: PushProvider -> ByteString -> DeviceToken
+deviceToken' :: PushProvider -> B.ByteString -> DeviceToken
 deviceToken' pp t = case pp of
   PPAPNS p -> APNSDeviceToken p t
   PPWP p -> WPDeviceToken p <$> either error id $ strDecode t
 
+wpRequest :: MonadFail m => DeviceToken -> m Request
+wpRequest (APNSDeviceToken _ _) = fail "Invalid device token"
+wpRequest (WPDeviceToken (WPP s) param) = do
+  let endpoint = strEncode s <> wpPath param
+  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,
 -- and encoding of PNMessageData's smpQueue has comma in list of hosts
-encodePNMessages :: NonEmpty PNMessageData -> ByteString
+encodePNMessages :: NonEmpty PNMessageData -> B.ByteString
 encodePNMessages = B.intercalate ";" . map strEncode . L.toList
 
 pnMessagesP :: A.Parser (NonEmpty PNMessageData)
@@ -601,7 +756,7 @@ data NtfSubStatus
   | -- | SMP SERVICE error - rejected service signature on individual subscriptions
     NSService
   | -- | SMP error other than AUTH
-    NSErr ByteString
+    NSErr B.ByteString
   deriving (Eq, Ord, Show)
 
 ntfShouldSubscribe :: NtfSubStatus -> Bool

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

@@ -47,7 +47,7 @@ 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 (newManager, ManagerSettings (..), Request (..), Manager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 
 data NtfServerConfig = NtfServerConfig
@@ -165,25 +165,35 @@ newNtfPushServer qSize apnsConfig = do
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 newPushClient s pp = do
   case pp of
-    PPWebPush -> newWPPushClient s
-    _ -> newAPNSPushClient s pp
+    PPWP p -> newWPPushClient s p
+    PPAPNS p -> newAPNSPushClient s p
 
-newAPNSPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
+newAPNSPushClient :: NtfPushServer -> APNSProvider -> 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
+  atomically $ TM.insert (PPAPNS pp) c pushClients
   pure c
 
-newWPPushClient :: NtfPushServer -> IO PushProviderClient
-newWPPushClient NtfPushServer {pushClients} = do
+newWPPushClient :: NtfPushServer -> WPProvider -> IO PushProviderClient
+newWPPushClient NtfPushServer {pushClients} pp = do
   logDebug "New WP Client requested"
-  manager <- newManager tlsManagerSettings
+  -- We use one http manager per push server (which may be used by different clients)
+  manager <- wpHTTPManager
   let c = wpPushProviderClient manager
-  atomically $ TM.insert PPWebPush c pushClients
+  atomically $ TM.insert (PPWP pp) c pushClients
   pure c
 
+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 -> IO PushProviderClient
 getPushClient s@NtfPushServer {pushClients} pp =
   TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure

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

@@ -257,8 +257,8 @@ $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 
 -- TODO [webpush] change type accept token components so it only allows APNS token
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token} pn = do
-  tknStr <- deviceToken token
+apnsPushProviderClient _ NtfTknRec {token = WPDeviceToken _ _} _ = throwE PPInvalidPusher
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = APNSDeviceToken _ tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.randomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
@@ -272,9 +272,6 @@ 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 =

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

@@ -1,10 +1,7 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use newtype instead of data" #-}
@@ -13,7 +10,7 @@ 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.Protocol (DeviceToken (WPDeviceToken, APNSDeviceToken), encodePNMessages, PNMessageData, WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, authToByteString, wpRequest)
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.Push
 import Control.Monad.Except
@@ -26,7 +23,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)
@@ -36,20 +32,18 @@ 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
-  -- TODO [webpush] parsing will happen in DeviceToken parser, so it won't fail here
+wpPushProviderClient _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher
+wpPushProviderClient mg NtfTknRec {token = token@(WPDeviceToken _ param)} pn = do
   -- TODO [webpush] this function should accept type that is restricted to WP token (so, possibly WPProvider and WPTokenParams)
-  wpe@WPEndpoint {endpoint} <- tokenEndpoint tkn
-  r <- liftPPWPError $ parseUrlThrow $ B.unpack endpoint
+  -- parsing will happen in DeviceToken parser, so it won't fail here
+  r <- wpRequest token
   logDebug $ "Request to " <> tshow (host r)
-  encBody <- body wpe
+  encBody <- body
   let requestHeaders =
         [ ("TTL", "2592000"), -- 30 days
           ("Urgency", "high"),
@@ -66,27 +60,26 @@ wpPushProviderClient mg tkn pn = do
   _ <- liftPPWPError $ httpNoBody req mg
   pure ()
   where
-    tokenEndpoint :: NtfTknRec -> ExceptT PushProviderError IO WPEndpoint
-    tokenEndpoint NtfTknRec {token} = do
-      case token of
-        WPDeviceToken _p 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 WPEndpoint {auth, p256dh} = withExceptT PPCryptoError $ wpEncrypt auth p256dh (BL.toStrict $ encodePN pn)
+    body :: ExceptT PushProviderError IO B.ByteString
+    body = withExceptT PPCryptoError $ wpEncrypt (wpKey param) (BL.toStrict $ encodePN pn)
 
--- | encrypt :: auth -> key -> clear -> cipher
+-- | encrypt :: UA 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
+wpEncrypt :: WPKey -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
+wpEncrypt wpKey clearT = do
   salt :: B.ByteString <- liftIO $ getRandomBytes 16
   asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
-  -- TODO [webpush] key parsing will happen in DeviceToken parser, so it won't fail here
-  uaPubK <- point uaPubKS
-  let asPubK = BL.toStrict . uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
+  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 -> B.ByteString -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
+wpEncrypt' WPKey {wpAuth, wpP256dh = WPP256dh uaPubK} asPrivK salt clearT = do
+  let uaPubKS = BL.toStrict . uncompressEncodePoint $ uaPubK
+  let asPubKS = BL.toStrict . uncompressEncodePoint . 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
+      keyInfo = "WebPush: info\0" <> uaPubKS <> asPubKS
       ikm = hmac prkKey (keyInfo <> "\x01")
       prk = hmac salt ikm
       cekInfo = "Content-Encoding: aes128gcm\0" :: B.ByteString
@@ -95,14 +88,18 @@ wpEncrypt auth uaPubKS clearT = do
       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
+      header = salt <> rs <> idlen <> asPubKS
   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"
+  -- Uncomment to see intermediate values, to compare with RFC8291 example
+  -- liftIO . print $ strEncode (BA.convert ecdhSecret :: B.ByteString)
+  -- liftIO . print . strEncode $ takeHM 32 prkKey
+  -- liftIO . print $ strEncode cek
+  -- liftIO . print $ strEncode cipherT
   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
+    auth = authToByteString wpAuth
     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
@@ -111,46 +108,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
--- TODO [webpush] add them to the encoding of WPKey
-uncompressEncode :: ECC.Point -> BL.ByteString
-uncompressEncode (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y
-uncompressEncode ECC.PointO = "\0"
-
--- TODO [webpush] should be -> Either ... (which it would be in StrEncoding)
-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
-
--- TODO [webpush] should be -> Either ... (which it would be in StrEncoding)
-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)
-
 -- TODO [webpush] use ToJSON
 encodePN :: PushNotification -> BL.ByteString
 encodePN pn = J.encode $ case pn of

src/Simplex/Messaging/Protocol.hs

@@ -1147,7 +1147,7 @@ sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
 sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
 {-# INLINE sameSrvAddr #-}
 
-data ProtocolType = PSMP | PNTF | PXFTP | PHTTPS
+data ProtocolType = PSMP | PNTF | PXFTP
   deriving (Eq, Ord, Show)
 
 instance StrEncoding ProtocolType where
@@ -1155,20 +1155,17 @@ instance StrEncoding ProtocolType where
     PSMP -> "smp"
     PNTF -> "ntf"
     PXFTP -> "xftp"
-    PHTTPS -> "https"
   strP =
     A.takeTill (\c -> c == ':' || c == ' ') >>= \case
       "smp" -> pure PSMP
       "ntf" -> pure PNTF
       "xftp" -> pure PXFTP
-      "https" -> pure PHTTPS
       _ -> fail "bad ProtocolType"
 
 data SProtocolType (p :: ProtocolType) where
   SPSMP :: SProtocolType 'PSMP
   SPNTF :: SProtocolType 'PNTF
   SPXFTP :: SProtocolType 'PXFTP
-  SPHTTPS :: SProtocolType 'PHTTPS
 
 deriving instance Eq (SProtocolType p)
 
@@ -1187,7 +1184,6 @@ instance TestEquality SProtocolType where
   testEquality SPSMP SPSMP = Just Refl
   testEquality SPNTF SPNTF = Just Refl
   testEquality SPXFTP SPXFTP = Just Refl
-  testEquality SPHTTPS SPHTTPS = Just Refl
   testEquality _ _ = Nothing
 
 protocolType :: SProtocolType p -> ProtocolType
@@ -1195,14 +1191,12 @@ protocolType = \case
   SPSMP -> PSMP
   SPNTF -> PNTF
   SPXFTP -> PXFTP
-  SPHTTPS -> PHTTPS
 
 aProtocolType :: ProtocolType -> AProtocolType
 aProtocolType = \case
   PSMP -> AProtocolType SPSMP
   PNTF -> AProtocolType SPNTF
   PXFTP -> AProtocolType SPXFTP
-  PHTTPS -> AProtocolType SPHTTPS
 
 instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
   strEncode = strEncode . protocolType
@@ -1240,8 +1234,6 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 
 instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP
 
-instance ProtocolTypeI 'PHTTPS where protocolTypeI = SPHTTPS
-
 type family UserProtocol (p :: ProtocolType) :: Constraint where
   UserProtocol PSMP = ()
   UserProtocol PXFTP = ()

src/Simplex/Messaging/ServiceScheme.hs

@@ -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 "")

tests/AgentTests/NotificationTests.hs

@@ -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), PPAPNS PPApnsTest, "abcd" :: ByteString)
     Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1500000
@@ -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, PPAPNS PPApnsTest, "abcd" :: ByteString)
     Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1000000

tests/NtfClient.hs

@@ -60,6 +60,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"
@@ -293,6 +294,7 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
 getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
+getMockNotification _ (WPDeviceToken _ _) = liftIO . throwIO $ userError "Invalid pusher"
 getMockNotification APNSMockServer {notifications} (APNSDeviceToken _ token) = do
   atomically $ TM.lookup token notifications >>= maybe retry readTBQueue
 

tests/NtfWPTests.hs

@@ -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', encodePN)
+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 DeviceToken
+  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 :: BL.ByteString = either error BL.fromStrict $ 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` "{\"message\":\"smp://AAAA@l/AAAA 1761827386 bm9uY2UAAAAAAAAAAAAAAAAAAAAAAAAA TXlNZXNzYWdl\"}"
+  where
+    enc p = BL.toStrict $ encodePN 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 :| []

tests/Test.hs

@@ -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)