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