diff --git a/simplexmq.cabal b/simplexmq.cabal index 57ceaa599..96315a9a0 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -305,6 +305,7 @@ library , containers ==0.6.* , crypton ==0.34.* , crypton-x509 ==1.7.* + , crypton-x509-system ==1.6.* , crypton-x509-store ==1.6.* , crypton-x509-validation ==1.6.* , cryptostore ==0.3.* diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 83608ebcd..5fbc938b2 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -33,7 +33,7 @@ import Simplex.Messaging.Notifications.Server.Store.Postgres import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore) import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF) -import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), Transmission) +import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), Transmission, SrvLoc (..)) import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) @@ -46,9 +46,10 @@ import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, Transport import System.Exit (exitFailure) import System.Mem.Weak (Weak) import UnliftIO.STM -import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClient) +import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClientH1, wpPushProviderClientH2, wpHTTP2Client) import Network.HTTP.Client (newManager, ManagerSettings (..), Request (..), Manager) import Network.HTTP.Client.TLS (tlsManagerSettings) +import Simplex.Messaging.Util (tshow) data NtfServerConfig = NtfServerConfig { transports :: [(ServiceName, ASrvTransport, AddHTTP)], @@ -177,10 +178,14 @@ newAPNSPushClient NtfPushServer {apnsConfig, pushClients} pp = do Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig newWPPushClient :: NtfPushServer -> WPProvider -> IO PushProviderClient -newWPPushClient NtfPushServer {pushClients} pp = do +newWPPushClient NtfPushServer {pushClients} (WPP (WPSrvLoc (SrvLoc h p))) = do logDebug "New WP Client requested" - -- We use one http manager per push server (which may be used by different clients) - wpPushProviderClient <$> wpHTTPManager + r <- wpHTTP2Client h p + case r of + Right client -> pure $ wpPushProviderClientH2 client + Left e -> do + logError $ "Error connecting to H2 WP: " <> tshow e + wpPushProviderClientH1 <$> wpHTTPManager wpHTTPManager :: IO Manager wpHTTPManager = newManager tlsManagerSettings { diff --git a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs index 9b1ebb9f8..8753f40e8 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs @@ -8,9 +8,8 @@ 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 (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest) +import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest, WPProvider (..)) import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Server.Push import Control.Monad.Except @@ -19,7 +18,6 @@ import Simplex.Messaging.Util (tshow) import qualified Data.ByteString.Char8 as B import Control.Monad.IO.Class (liftIO) import Control.Exception ( fromException, SomeException, try ) -import qualified Network.HTTP.Types as N import qualified Data.Aeson as J import Data.Aeson ((.=)) import qualified Data.Binary as Bin @@ -32,25 +30,67 @@ import qualified Crypto.Cipher.Types as CT import qualified Crypto.MAC.HMAC as HMAC import qualified Crypto.PubKey.ECC.DH as ECDH import qualified Crypto.PubKey.ECC.Types as ECC +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, getHTTP2Client, defaultHTTP2ClientConfig, HTTP2ClientError, HTTP2Response (..), sendRequest) +import Network.Socket (ServiceName, HostName) +import System.X509.Unix +import qualified Network.HTTP.Types as N +import Network.HTTP.Client +import qualified Network.HTTP2.Client as H2 +import Data.ByteString.Builder (lazyByteString) +import Simplex.Messaging.Encoding.String (StrEncoding(..)) +import Data.Bifunctor (first) -wpPushProviderClient :: Manager -> PushProviderClient -wpPushProviderClient _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher -wpPushProviderClient mg NtfTknRec {token = token@(WPDeviceToken _ param)} pn = do +wpHTTP2Client :: HostName -> ServiceName -> IO (Either HTTP2ClientError HTTP2Client) +wpHTTP2Client h p = do + caStore <- Just <$> getSystemCertificateStore + let config = defaultHTTP2ClientConfig + getHTTP2Client h p caStore config nop + where + nop = pure () + +wpHeaders :: [(N.HeaderName, B.ByteString)] +wpHeaders = [ + -- Why http2-client doesn't accept TTL AND Urgency? + -- Keeping Urgency for now, the TTL should be around 30 days by default on the push servers + -- ("TTL", "2592000"), -- 30 days + ("Urgency", "high"), + ("Content-Encoding", "aes128gcm") + -- TODO: topic for pings and interval + ] + +wpHTTP2Req :: B.ByteString -> BL.ByteString -> H2.Request +wpHTTP2Req path s = H2.requestBuilder N.methodPost path wpHeaders (lazyByteString s) + +wpPushProviderClientH2 :: HTTP2Client -> PushProviderClient +wpPushProviderClientH2 _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher +wpPushProviderClientH2 http2 NtfTknRec {token = (WPDeviceToken (WPP p) param)} 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 + encBody <- body + let req = wpHTTP2Req (wpPath param) $ BL.fromStrict encBody + logDebug $ "HTTP/2 Request to " <> tshow (strEncode p) + HTTP2Response {response} <- liftHTTPS2 $ sendRequest http2 req Nothing + let status = H2.responseStatus response + if status >= Just N.ok200 && status < Just N.status300 + then pure () + else throwError $ fromStatusCode status + where + body :: ExceptT PushProviderError IO B.ByteString + body = withExceptT PPCryptoError $ wpEncrypt (wpKey param) (BL.toStrict $ encodeWPN pn) + liftHTTPS2 a = ExceptT $ first PPConnection <$> a + +wpPushProviderClientH1 :: Manager -> PushProviderClient +wpPushProviderClientH1 _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher +wpPushProviderClientH1 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) -- parsing will happen in DeviceToken parser, so it won't fail here r <- wpRequest token - logDebug $ "Request to " <> tshow (host r) + logDebug $ "HTTP/1 Request to " <> tshow (host r) encBody <- body - let requestHeaders = - [ ("TTL", "2592000"), -- 30 days - ("Urgency", "high"), - ("Content-Encoding", "aes128gcm") - -- TODO: topic for pings and interval - ] - req = + let req = r { method = "POST", - requestHeaders, + requestHeaders = wpHeaders, requestBody = RequestBodyBS encBody, redirectCount = 0 } @@ -122,13 +162,14 @@ liftPPWPError' err a = liftIO (try @SomeException a) >>= either (throwError . er toPPWPError :: SomeException -> PushProviderError toPPWPError e = case fromException e of Just (InvalidUrlException _ _) -> PPWPInvalidUrl - Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String) + Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (Just $ responseStatus resp) _ -> 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) + +fromStatusCode :: Maybe N.Status -> PushProviderError +fromStatusCode status + | status == Just N.status404 = PPWPRemovedEndpoint + | status == Just N.status410 = PPWPRemovedEndpoint + | status == Just N.status413 = PPWPRequestTooLong + | status == Just N.status429 = PPRetryLater + | status >= Just N.status500 = PPRetryLater + | otherwise = PPResponseError status "Invalid response" diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 0912e29b2..4f47b6342 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -216,11 +216,11 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do threadDelay 100000 testNotificationToken :: APNSMockServer -> IO () -testNotificationToken apns = do +testNotificationToken (APNSMockServer apns) = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -240,16 +240,16 @@ v .-> key = do -- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} testNtfTokenRepeatRegistration :: APNSMockServer -> IO () -testNtfTokenRepeatRegistration apns = do +testNtfTokenRepeatRegistration (APNSMockServer apns) = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- getMockNotification apns tkn _ <- ntfData' .-> "verification" _ <- C.cbNonce <$> ntfData' .-> "nonce" @@ -259,18 +259,18 @@ testNtfTokenRepeatRegistration apns = do pure () testNtfTokenSecondRegistration :: APNSMockServer -> IO () -testNtfTokenSecondRegistration apns = +testNtfTokenSecondRegistration (APNSMockServer apns) = withAgentClients2 $ \a a' -> runRight_ $ do let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification NTRegistered <- registerNtfToken a' tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- getMockNotification apns tkn verification' <- ntfData' .-> "verification" nonce' <- C.cbNonce <$> ntfData' .-> "nonce" @@ -289,12 +289,12 @@ testNtfTokenSecondRegistration apns = pure () testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenServerRestart t apns = do +testNtfTokenServerRestart t (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest "abcd" ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn pure ntfData -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server @@ -310,12 +310,12 @@ testNtfTokenServerRestart t apns = do pure () testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReverify t apns = do +testNtfTokenServerRestartReverify t (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> do ntfData <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn pure ntfData runRight_ $ do @@ -333,12 +333,12 @@ testNtfTokenServerRestartReverify t apns = do pure () testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReverifyTimeout t apns = do +testNtfTokenServerRestartReverifyTimeout t (APNSMockServer apns) = do let tkn = 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 - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -368,12 +368,12 @@ testNtfTokenServerRestartReverifyTimeout t apns = do pure () testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReregister t apns = do +testNtfTokenServerRestartReregister t (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- getMockNotification apns tkn pure () -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server @@ -383,7 +383,7 @@ testNtfTokenServerRestartReregister t apns = do -- so that repeat registration happens when client is restarted. withNtfServer t $ runRight_ $ do NTRegistered <- registerNtfToken a' tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -392,12 +392,12 @@ testNtfTokenServerRestartReregister t apns = do pure () testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReregisterTimeout t apns = do +testNtfTokenServerRestartReregisterTimeout t (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- getMockNotification apns tkn pure () -- this emulates the situation when server registered token but the client did not receive the response @@ -418,7 +418,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do -- so that repeat registration happens when client is restarted. withNtfServer t $ runRight_ $ do NTRegistered <- registerNtfToken a' tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -433,14 +433,14 @@ getTestNtfTokenPort a = Nothing -> error "no active NtfToken" testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO () -testNtfTokenMultipleServers t apns = do +testNtfTokenMultipleServers t (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers2 testDB $ \a -> withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do -- register a new token, the agent picks a server and stores its choice NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -543,7 +543,7 @@ testRunNTFServerTests t srv = testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do +testNotificationSubscriptionExistingConnection (APNSMockServer apns) baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -556,7 +556,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag -- register notification token let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken alice tkn NMInstant - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" vNonce <- C.cbNonce <$> ntfData .-> "nonce" @@ -566,7 +566,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" get bob ##> ("", aliceId, SENT $ baseId + 1) -- notification - (nonce, message) <- messageNotification apns tkn + (nonce, message) <- messageNotification (APNSMockServer apns) tkn pure (bobId, aliceId, nonce, message) Right [NotificationInfo {ntfConnId = cId, ntfMsgMeta = Just NMsgMeta {msgTs}}] <- runExceptT $ getNotificationConns alice nonce message @@ -599,7 +599,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag 2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT $ baseId + 2) -- no notifications should follow - noNotification alice apns + noNotification alice $ APNSMockServer apns where msgId = subtract baseId @@ -644,10 +644,10 @@ testNotificationSubscriptionNewConnection apns baseId alice bob = msgId = subtract baseId registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken -registerTestToken a token mode apns = do +registerTestToken a token mode (APNSMockServer apns) = do let tkn = APNSDeviceToken PPApnsTest token NTRegistered <- registerNtfToken a tkn mode - Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + Just PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- timeout 1000000 $ getMockNotification apns tkn verification' <- ntfData' .-> "verification" nonce' <- C.cbNonce <$> ntfData' .-> "nonce" @@ -1024,10 +1024,10 @@ testMessage_ apns a aId b bId msg = do ackMessage a bId msgId Nothing messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString) -messageNotification apns tkn = do +messageNotification (APNSMockServer apns) tkn = do 500000 `timeout` getMockNotification apns tkn >>= \case Nothing -> error "no notification" - Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do + Just PushMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do nonce <- C.cbNonce <$> ntfData .-> "nonce" message <- ntfData .-> "message" pure (nonce, message) @@ -1041,14 +1041,14 @@ messageNotificationData c apns = do pure $ L.last pnMsgs noNotification :: AgentClient -> APNSMockServer -> ExceptT AgentErrorType IO () -noNotification c apns = do +noNotification c (APNSMockServer apns) = do NtfToken {deviceToken} <- getNtfTokenData c 500000 `timeout` getMockNotification apns deviceToken >>= \case Nothing -> pure () _ -> error "unexpected notification" noNotifications :: APNSMockServer -> ExceptT AgentErrorType IO () -noNotifications apns = do +noNotifications (APNSMockServer apns) = do 500000 `timeout` getAnyMockNotification apns >>= \case Nothing -> pure () _ -> error "unexpected notification" diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index bdd57f61c..e614b8834 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -41,7 +41,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 (DeviceToken(..), NtfResponse, WPTokenParams(..)) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env import Simplex.Messaging.Notifications.Server.Push.APNS @@ -60,7 +60,10 @@ import UnliftIO.Async import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM -import Control.Exception (throwIO) +import Data.Aeson.Types ((.=)) +import qualified Network.HPACK as H +import qualified Network.HPACK.Token as H +import Data.Maybe (fromMaybe) testHost :: NonEmpty TransportHost testHost = "localhost" @@ -68,6 +71,9 @@ testHost = "localhost" apnsTestPort :: ServiceName apnsTestPort = "6010" +wpTestPort :: ServiceName +wpTestPort = "6011" + testKeyHash :: C.KeyHash testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" @@ -213,23 +219,34 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation ntfTest _ test' = runNtfTest test' `shouldReturn` () -data APNSMockRequest = APNSMockRequest - { notification :: APNSNotification +data PushMockRequest a = PushMockRequest + { notification :: a } -data APNSMockResponse = APNSRespOk | APNSRespError Status Text +data PushMockResponse = PushRespOk | PushRespError Status Text -data APNSMockServer = APNSMockServer +data PushMockServer a = PushMockServer { action :: Async (), - notifications :: TM.TMap ByteString (TBQueue APNSMockRequest), + notifications :: TM.TMap ByteString (TBQueue (PushMockRequest a)), http2Server :: HTTP2Server } -apnsMockServerConfig :: HTTP2ServerConfig -apnsMockServerConfig = +data WPNotification = WPNotification + { authorization :: Maybe ByteString, + encoding :: Maybe ByteString, + ttl :: Maybe ByteString, + urgency :: Maybe ByteString, + body :: ByteString + } + +newtype APNSMockServer = APNSMockServer (PushMockServer APNSNotification) +newtype WPMockServer = WPMockServer (PushMockServer WPNotification) + +pushMockServerConfig :: ServiceName -> HTTP2ServerConfig +pushMockServerConfig port = HTTP2ServerConfig { qSize = 2, - http2Port = apnsTestPort, + http2Port = port, bufferSize = 16384, bodyHeadSize = 16384, serverSupported = http2TLSParams, @@ -243,7 +260,14 @@ apnsMockServerConfig = } withAPNSMockServer :: (APNSMockServer -> IO a) -> IO a -withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer +withAPNSMockServer = E.bracket (getAPNSMockServer $ pushMockServerConfig apnsTestPort) closeAPNSMockServer + where + closeAPNSMockServer (APNSMockServer a) = closePushMockServer a + +withWPMockServer :: (WPMockServer -> IO a) -> IO a +withWPMockServer = E.bracket (getWPMockServer $ pushMockServerConfig wpTestPort) closeWPMockServer + where + closeWPMockServer (WPMockServer a) = closePushMockServer a deriving instance Generic APNSAlertBody @@ -273,36 +297,63 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do http2Server <- getHTTP2Server config notifications <- TM.emptyIO action <- async $ runAPNSMockServer notifications http2Server - pure APNSMockServer {action, notifications, http2Server} + pure $ APNSMockServer PushMockServer {action, notifications, http2Server} where runAPNSMockServer notifications HTTP2Server {reqQ} = forever $ do HTTP2Request {request, reqBody = HTTP2Body {bodyHead}, sendResponse} <- atomically $ readTBQueue reqQ let sendApnsResponse = \case - APNSRespOk -> sendResponse $ H.responseNoBody N.ok200 [] - APNSRespError status reason -> + PushRespOk -> sendResponse $ H.responseNoBody N.ok200 [] + PushRespError status reason -> sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason} case J.decodeStrict' bodyHead of Just notification -> do Just token <- pure $ B.stripPrefix "/3/device/" =<< H.requestPath request q <- atomically $ TM.lookup token notifications >>= maybe (newTokenQueue token) pure - atomically $ writeTBQueue q APNSMockRequest {notification} - sendApnsResponse APNSRespOk + atomically $ writeTBQueue q PushMockRequest {notification} + sendApnsResponse PushRespOk where newTokenQueue token = newTBQueue qSize >>= \q -> TM.insert token q notifications >> pure q _ -> do putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead - sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body" + sendApnsResponse $ PushRespError 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 +getWPMockServer :: HTTP2ServerConfig -> IO WPMockServer +getWPMockServer config@HTTP2ServerConfig {qSize} = do + http2Server <- getHTTP2Server config + notifications <- TM.emptyIO + action <- async $ runWPMockServer notifications http2Server + pure $ WPMockServer PushMockServer {action, notifications, http2Server} + where + runWPMockServer notifications HTTP2Server {reqQ} = forever $ do + HTTP2Request {request, reqBody = HTTP2Body {bodyHead}, sendResponse} <- atomically $ readTBQueue reqQ + let sendWPResponse = \case + PushRespOk -> sendResponse $ H.responseNoBody N.ok200 [] + PushRespError status reason -> + sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode $ J.object [ "error" .= reason] + path = fromMaybe "/default" $ H.requestPath request + (_, headers) = H.requestHeaders request + authorization = H.getHeaderValue H.tokenAuthorization headers + encoding = H.getHeaderValue H.tokenContentEncoding headers + ttl = H.getHeaderValue (H.toToken "TTL") headers + urgency = H.getHeaderValue (H.toToken "urgency") headers + notification = WPNotification {body = bodyHead, authorization, encoding, ttl, urgency} + q <- atomically $ TM.lookup path notifications >>= maybe (newTokenQueue path) pure + atomically $ writeTBQueue q PushMockRequest {notification} + sendWPResponse PushRespOk + where + newTokenQueue path = newTBQueue qSize >>= \q -> TM.insert path q notifications >> pure q + +getMockNotification :: MonadIO m => PushMockServer a -> DeviceToken -> m (PushMockRequest a) +getMockNotification PushMockServer {notifications} (WPDeviceToken _ (WPTokenParams path _)) = do + atomically $ TM.lookup path notifications >>= maybe retry readTBQueue +getMockNotification PushMockServer {notifications} (APNSDeviceToken _ token) = do atomically $ TM.lookup token notifications >>= maybe retry readTBQueue -getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest -getAnyMockNotification APNSMockServer {notifications} = do +getAnyMockNotification :: MonadIO m => PushMockServer a -> m (PushMockRequest a) +getAnyMockNotification PushMockServer {notifications} = do atomically $ readTVar notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf -closeAPNSMockServer :: APNSMockServer -> IO () -closeAPNSMockServer APNSMockServer {action, http2Server} = do +closePushMockServer :: PushMockServer a -> IO () +closePushMockServer PushMockServer {action, http2Server} = do closeHTTP2Server http2Server uninterruptibleCancel action diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index c4dd72b24..4aab1845e 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -48,11 +48,14 @@ import Simplex.Messaging.Transport import Test.Hspec hiding (fit, it) import UnliftIO.STM import Util +import Simplex.Messaging.Encoding.String (StrEncoding(..)) +import System.Environment (setEnv) ntfServerTests :: (ASrvTransport, AStoreType) -> Spec ntfServerTests ps@(t, _) = do describe "Notifications server protocol syntax" $ ntfSyntaxTests t - describe "Notification subscriptions (NKEY)" $ testNotificationSubscription ps createNtfQueueNKEY + describe "APNS notification subscriptions (NKEY)" $ testAPNSNotificationSubscription ps createNtfQueueNKEY + describe "WP notification subscriptions (NKEY)" $ testWPNotificationSubscription ps createNtfQueueNKEY -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription ps createNtfQueueNEW describe "Retried notification subscription" $ testRetriedNtfSubscription ps @@ -99,22 +102,22 @@ v .-> key = let J.Object o = v in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o -testNotificationSubscription :: (ASrvTransport, AStoreType) -> CreateQueueFunc -> Spec -testNotificationSubscription (ATransport t, msType) createQueue = - it "should create notification subscription and notify when message is received" $ do +testAPNSNotificationSubscription :: (ASrvTransport, AStoreType) -> CreateQueueFunc -> Spec +testAPNSNotificationSubscription (ATransport t, msType) createQueue = + it "should create APNS notification subscription and notify when message is received" $ do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (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 = APNSDeviceToken PPApnsTest "abcd" - withAPNSMockServer $ \apns -> + withAPNSMockServer $ \(APNSMockServer apns) -> smpTest2 t msType $ \rh sh -> ntfTest t $ \nh -> do ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) <- createQueue rh sPub nPub -- register and verify 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}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn let dhSecret = C.dh' ntfDh dhPriv decryptCode nd = @@ -127,7 +130,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = RespNtf "1a" NoEntity (NRTknId tId1 ntfDh1) <- signSendRecvNtf nh tknKey ("1a", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) tId1 `shouldBe` tId ntfDh1 `shouldBe` ntfDh - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData1}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData1}} <- getMockNotification apns tkn let code1 = decryptCode ntfData1 code `shouldBe` code1 @@ -141,7 +144,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = threadDelay 50000 Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello") -- receive notification - APNSMockRequest {notification} <- getMockNotification apns tkn + PushMockRequest {notification} <- getMockNotification apns tkn let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification Right nonce' = C.cbNonce <$> ntfData' .-> "nonce" Right message = ntfData' .-> "message" @@ -163,7 +166,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = let tkn' = 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}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <- getMockNotification apns tkn' let Right verification2 = ntfData2 .-> "verification" Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce" @@ -172,7 +175,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK) -- send message Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2") - APNSMockRequest {notification = notification3} <- getMockNotification apns tkn' + PushMockRequest {notification = notification3} <- getMockNotification apns tkn' let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3 Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce" Right message3 = ntfData3 .-> "message" @@ -182,6 +185,33 @@ testNotificationSubscription (ATransport t, msType) createQueue = smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId +testWPNotificationSubscription :: (ASrvTransport, AStoreType) -> CreateQueueFunc -> Spec +testWPNotificationSubscription (ATransport t, msType) createQueue = + it "should create WP notification subscription and notify when message is received" $ do + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (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 params ::WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM" + tkn = WPDeviceToken (WPP $ WPSrvLoc $ SrvLoc "localhost" wpTestPort) params + _ <- setEnv "SYSTEM_CERTIFICATE_PATH" "tests/fixtures/" + withWPMockServer $ \(WPMockServer wp) -> + smpTest2 t msType $ \rh sh -> + ntfTest t $ \nh -> do + ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) <- createQueue rh sPub nPub + -- register and verify token + RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) + PushMockRequest {notification = WPNotification {authorization, encoding, ttl, urgency, body}} <- + getMockNotification wp tkn + encoding `shouldBe` Just "aes128gcm" + -- We can't pass TTL and Urgency ATM + -- ttl `shouldBe` Just "2592000" + urgency `shouldBe` Just "high" + -- TODO: uncomment when vapid is merged + -- authorization `shouldContainBS` "vapid t=" + + testRetriedNtfSubscription :: (ASrvTransport, AStoreType) -> Spec testRetriedNtfSubscription (ATransport t, msType) = it "should allow retrying to create notification subscription with the same token and key" $ do @@ -233,13 +263,13 @@ createNtfQueueNKEY h sPub nPub = do pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) registerToken :: Transport c => THandleNTF c 'TClient -> APNSMockServer -> ByteString -> IO (C.APrivateAuthKey, C.DhSecretX25519, NtfEntityId, NtfRegCode) -registerToken nh apns token = do +registerToken nh (APNSMockServer apns) token = do g <- C.newRandom (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = 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}} <- + PushMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn let dhSecret = C.dh' ntfDh dhPriv decryptCode nd =