Prepare webpush requests

Author: p1gp1g

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.*

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

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

@@ -46,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)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
 
 data NtfServerConfig = NtfServerConfig
   { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
@@ -160,13 +163,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

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

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)