From 51be2fea20dc35d7f663d95b7dd1392b53c9c72c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 17 Feb 2024 14:55:40 +0000 Subject: [PATCH] agent: test NTF server (#1000) --- src/Simplex/Messaging/Agent.hs | 3 +- src/Simplex/Messaging/Agent/Client.hs | 28 +++++++++++++++++++ .../Messaging/Notifications/Protocol.hs | 10 ++++++- .../Messaging/Notifications/Server/Env.hs | 4 ++- .../Notifications/Server/Push/APNS.hs | 9 +++--- src/Simplex/Messaging/Protocol.hs | 3 ++ tests/AgentTests/NotificationTests.hs | 20 +++++++++++-- 7 files changed, 67 insertions(+), 10 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 249a97ae0..135319845 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -341,10 +341,11 @@ setProtocolServers :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMo setProtocolServers c = withAgentEnv c .: setProtocolServers' c -- | Test protocol server -testProtocolServer :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> ProtoServerWithAuth p -> m (Maybe ProtocolTestFailure) +testProtocolServer :: forall p m. (ProtocolTypeI p, AgentErrorMonad m) => AgentClient -> UserId -> ProtoServerWithAuth p -> m (Maybe ProtocolTestFailure) testProtocolServer c userId srv = withAgentEnv c $ case protocolTypeI @p of SPSMP -> runSMPServerTest c userId srv SPXFTP -> runXFTPServerTest c userId srv + SPNTF -> runNTFServerTest c userId srv setNtfServers :: MonadUnliftIO m => AgentClient -> [NtfServer] -> m () setNtfServers c = withAgentEnv c . setNtfServers' c diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 11ca6cde0..31c008193 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -31,6 +31,7 @@ module Simplex.Messaging.Agent.Client closeXFTPServerClient, runSMPServerTest, runXFTPServerTest, + runNTFServerTest, getXFTPWorkPath, newRcvQueue, subscribeQueues, @@ -189,6 +190,7 @@ import Simplex.Messaging.Protocol MsgFlags (..), MsgId, NtfServer, + NtfServerWithAuth, ProtoServer, ProtoServerWithAuth (..), Protocol (..), @@ -849,6 +851,8 @@ data ProtocolTestStep | TSDownloadFile | TSCompareFile | TSDeleteFile + | TSCreateNtfToken + | TSDeleteNtfToken deriving (Eq, Show) data ProtocolTestFailure = ProtocolTestFailure @@ -931,6 +935,30 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do createTestChunk :: FilePath -> IO () createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom +runNTFServerTest :: AgentMonad m => AgentClient -> UserId -> NtfServerWithAuth -> m (Maybe ProtocolTestFailure) +runNTFServerTest c userId (ProtoServerWithAuth srv _) = do + cfg <- getClientConfig c ntfCfg + C.AuthAlg a <- asks $ rcvAuthAlg . config + g <- asks random + liftIO $ do + let tSess = (userId, srv, Nothing) + getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case + Right ntf -> do + (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g + (dhKey, _) <- atomically $ C.generateKeyPair g + r <- runExceptT $ do + let deviceToken = DeviceToken PPApnsNull "test_ntf_token" + (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey) + liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId + ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf + incClientStat c userId ntf "NTF_TEST" "OK" + pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok + Left e -> pure (Just $ testErr TSConnect e) + where + addr = B.unpack $ strEncode srv + testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure + testErr step = ProtocolTestFailure step . protocolClientError SMP addr + getXFTPWorkPath :: AgentMonad m => m FilePath getXFTPWorkPath = do workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent) diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 854d7c94b..73c2dada6 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -358,7 +358,11 @@ instance StrEncoding SMPQueueNtf where notifierId <- A.char '/' *> strP pure SMPQueueNtf {smpServer, notifierId} -data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest +data PushProvider + = 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 @@ -366,11 +370,13 @@ instance Encoding PushProvider where PPApnsDev -> "AD" PPApnsProd -> "AP" PPApnsTest -> "AT" + PPApnsNull -> "AN" smpP = A.take 2 >>= \case "AD" -> pure PPApnsDev "AP" -> pure PPApnsProd "AT" -> pure PPApnsTest + "AN" -> pure PPApnsNull _ -> fail "bad PushProvider" instance StrEncoding PushProvider where @@ -378,11 +384,13 @@ instance StrEncoding PushProvider where PPApnsDev -> "apns_dev" PPApnsProd -> "apns_prod" PPApnsTest -> "apns_test" + PPApnsNull -> "apns_null" strP = A.takeTill (== ' ') >>= \case "apns_dev" -> pure PPApnsDev "apns_prod" -> pure PPApnsProd "apns_test" -> pure PPApnsTest + "apns_null" -> pure PPApnsNull _ -> fail "bad PushProvider" instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index ec2290b40..9e3013a8d 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -143,7 +143,9 @@ newNtfPushServer qSize apnsConfig = do newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient newPushClient NtfPushServer {apnsConfig, pushClients} pp = do - c <- apnsPushProviderClient <$> createAPNSPushClient (apnsProviderHost pp) apnsConfig + c <- case apnsProviderHost pp of + Nothing -> pure $ \_ _ -> pure () + Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig atomically $ TM.insert pp c pushClients pure c diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 5d8e298ea..9c3de04df 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -193,11 +193,12 @@ data APNSPushClientConfig = APNSPushClientConfig caStoreFile :: FilePath } -apnsProviderHost :: PushProvider -> HostName +apnsProviderHost :: PushProvider -> Maybe HostName apnsProviderHost = \case - PPApnsTest -> "localhost" - PPApnsDev -> "api.sandbox.push.apple.com" - PPApnsProd -> "api.push.apple.com" + PPApnsNull -> Nothing + PPApnsTest -> Just "localhost" + PPApnsDev -> Just "api.sandbox.push.apple.com" + PPApnsProd -> Just "api.push.apple.com" defaultAPNSPushClientConfig :: APNSPushClientConfig defaultAPNSPushClientConfig = diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index dfac5d570..315a4e5a3 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -80,6 +80,7 @@ module Simplex.Messaging.Protocol SMPServerWithAuth, NtfServer, pattern NtfServer, + NtfServerWithAuth, XFTPServer, pattern XFTPServer, XFTPServerWithAuth, @@ -696,6 +697,8 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash {-# COMPLETE NtfServer #-} +type NtfServerWithAuth = ProtoServerWithAuth 'PNTF + type XFTPServer = ProtocolServer 'PXFTP pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index e5d6ad7db..95f1280f5 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -23,12 +23,13 @@ import qualified Data.Aeson.Types as JT import Data.Bifunctor (bimap, first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) import NtfClient -import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer2) +import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2) import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent -import Simplex.Messaging.Agent.Client (withStore') +import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken) @@ -38,7 +39,7 @@ import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Types (NtfToken (..)) -import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) +import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) @@ -72,6 +73,11 @@ notificationTests t = do it "should keep working with active token until replaced" $ withAPNSMockServer $ \apns -> testNtfTokenChangeServers t apns + describe "notification server tests" $ do + it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing + let srv1 = testNtfServer {keyHash = "1234"} + it "should fail with incorrect fingerprint" $ do + testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) describe "Managing notification subscriptions" $ do describe "should create notification subscription for existing connection" $ testNtfMatrix t testNotificationSubscriptionExistingConnection @@ -313,6 +319,14 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} = tkn <- registerTestToken a "qwer" NMInstant apnsQ checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive +testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) +testRunNTFServerTests t srv = + withNtfServerThreadOn t ntfTestPort $ \ntf -> do + a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB + r <- runRight $ testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing + killThread ntf + pure r + testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do