agent: test NTF server (#1000)

src/Simplex/Messaging/Agent.hs

@@ -338,10 +338,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

src/Simplex/Messaging/Agent/Client.hs

@@ -32,6 +32,7 @@ module Simplex.Messaging.Agent.Client
     closeXFTPServerClient,
     runSMPServerTest,
     runXFTPServerTest,
+    runNTFServerTest,
     getXFTPWorkPath,
     newRcvQueue,
     subscribeQueues,
@@ -193,6 +194,7 @@ import Simplex.Messaging.Protocol
     MsgFlags (..),
     MsgId,
     NtfServer,
+    NtfServerWithAuth,
     ProtoServer,
     ProtoServerWithAuth (..),
     Protocol (..),
@@ -868,6 +870,8 @@ data ProtocolTestStep
   | TSDownloadFile
   | TSCompareFile
   | TSDeleteFile
+  | TSCreateNtfToken
+  | TSDeleteNtfToken
   deriving (Eq, Show)
 
 data ProtocolTestFailure = ProtocolTestFailure
@@ -945,6 +949,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)

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

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

@@ -142,7 +142,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
 

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 =

src/Simplex/Messaging/Protocol.hs

@@ -79,6 +79,7 @@ module Simplex.Messaging.Protocol
     SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    NtfServerWithAuth,
     XFTPServer,
     pattern XFTPServer,
     XFTPServerWithAuth,
@@ -674,6 +675,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

tests/AgentTests/NotificationTests.hs

@@ -21,13 +21,14 @@ 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 SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
+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.Env.SQLite (InitialAgentServers)
+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)
 import qualified Simplex.Messaging.Crypto as C
@@ -35,7 +36,7 @@ import Simplex.Messaging.Encoding.String
 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)
@@ -49,63 +50,37 @@ removeFileIfExists filePath = do
   when fileExists $ removeFile filePath
 
 notificationTests :: ATransport -> Spec
-notificationTests t =
-  after_ (removeFileIfExists testDB >> removeFileIfExists testDB2) $ do
-    describe "Managing notification tokens" $ do
-      it "should register and verify notification token" $
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationToken apns
-      it "should allow repeated registration with the same credentials" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNtfTokenRepeatRegistration apns
-      it "should allow the second registration with different credentials and delete the first after verification" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNtfTokenSecondRegistration apns
-      it "should re-register token when notification server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenServerRestart t apns
-      it "should work with multiple configured servers" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenMultipleServers t apns
-      it "should keep working with active token until replaced" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenChangeServers t apns
-    describe "Managing notification subscriptions" $ do
-      -- fails on Ubuntu CI?
-      xit' "should create notification subscription for existing connection" $ \_ -> do
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testNotificationSubscriptionExistingConnection apns
-      it "should create notification subscription for new connection" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testNotificationSubscriptionNewConnection apns
-      it "should change notifications mode" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeNotificationsMode apns
-      it "should change token" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeToken apns
-    describe "Notifications server store log" $
-      it "should save and restore tokens and subscriptions" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            testNotificationsStoreLog t apns
-    describe "Notifications after SMP server restart" $
-      it "should resume subscriptions after SMP server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationsSMPRestart t apns
-    describe "Notifications after SMP server restart" $
-      it "should resume batched subscriptions after SMP server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
-    describe "should switch notifications to the new queue" $
-      testServerMatrix2 t $ \servers ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testSwitchNotifications servers apns
-    it "should keep sending notifications for old token" $
+notificationTests t = do
+  describe "Managing notification tokens" $ do
+    it "should register and verify notification token" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNotificationToken apns
+    it "should allow repeated registration with the same credentials" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNtfTokenRepeatRegistration apns
+    it "should allow the second registration with different credentials and delete the first after verification" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNtfTokenSecondRegistration apns
+    it "should re-register token when notification server is restarted" $
+      withAPNSMockServer $ \apns ->
+        testNtfTokenServerRestart t apns
+    it "should work with multiple configured servers" $
+      withAPNSMockServer $ \apns ->
+        testNtfTokenMultipleServers t apns
+    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
+    describe "should create notification subscription for new connection" $
+      testNtfMatrix t testNotificationSubscriptionNewConnection
+    it "should change notifications mode" $
       withSmpServer t $
         withAPNSMockServer $ \apns ->
           withNtfServerOn t ntfTestPort $
@@ -294,10 +269,16 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
       tkn <- registerTestToken a "qwer" NMInstant apnsQ
       checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
 
-testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
-testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+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
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe