dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-30 16:26:02 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
7565ddd91c74010da2f443a76259276e8a429caf
simplexmq/tests/AgentTests/NotificationTests.hs

881 lines
42 KiB
Haskell
Raw Blame History

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module AgentTests.NotificationTests where
-- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
import AgentTests.FunctionalAPITests
( agentCfgVPrevPQ,
createConnection,
exchangeGreetings,
get,
joinConnection,
makeConnection,
nGet,
runRight,
runRight_,
sendMessage,
switchComplete,
testServerMatrix2,
withAgent,
withAgentClients2,
withAgentClients3,
withAgentClientsCfg2,
withAgentClientsCfgServers2,
(##>),
(=##>),
pattern CON,
pattern CONF,
pattern INFO,
pattern Msg,
pattern SENT,
)
import Control.Concurrent (ThreadId, killThread, threadDelay)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader (runReaderT)
import Control.Monad.Trans.Except
import qualified Data.Aeson as J
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 Database.SQLite.Simple.QQ (sql)
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore, withTransaction)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
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)
import System.Directory (doesFileExist, removeFile)
import Test.Hspec
import UnliftIO
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists filePath = do
fileExists <- doesFileExist filePath
when fileExists $ removeFile filePath
notificationTests :: ATransport -> Spec
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 verify token after notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestart t apns
it "should re-verify token after notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReverify t apns
it "should re-verify token after notification server is restarted when first request timed-out" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReverifyTimeout t apns
it "should re-register token when notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReregister t apns
it "should re-register token when notification server is restarted when first request timed-out" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReregisterTimeout 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 ->
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" $
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServerOn t ntfTestPort $
testNotificationsOldToken apns
it "should update server from new token" $
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
testNotificationsNewToken apns ntf
testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix t runTest = do
describe "next and current" $ do
it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
-- servers can be upgraded in any order
it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
-- one of two clients can be upgraded
it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest
it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest
runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do
withSmpServerConfigOn t smpCfg testPort $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId
threadDelay 100000
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken APNSMockServer {apnsQ} = do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED _) <- tryE $ checkNtfToken a tkn
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
v .-> key = do
J.Object o <- pure v
liftEither . bimap INTERNAL (U.decodeLenient . encodeUtf8) $ JT.parseEither (J..: key) o
-- logCfg :: LogConfig
-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
_ <- ntfData' .-> "verification"
_ <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- can still use the first verification code, it is the same after decryption
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
pure ()
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
withAgentClients2 $ \a a' -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn nonce verification
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- at this point the first token is still active
NTActive <- checkNtfToken a tkn
-- and the second is not yet verified
liftIO $ threadDelay 50000
NTConfirmed <- checkNtfToken a' tkn
-- now the second token registration is verified
verifyNtfToken a' tkn nonce' verification'
-- the first registration is removed
Left (NTF _ AUTH) <- tryE $ checkNtfToken a tkn
-- and the second is active
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
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
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServerStoreLog t $ \_ -> runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a -> do
ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
pure ntfData
runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTActive <- registerNtfToken a' tkn NMPeriodic
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
(nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
pure (nonce, verification)
-- this emulates the situation when server verified token but the client did not receive the response
Just NtfToken {ntfTknStatus = NTActive, ntfTknAction = Just NTACheck, ntfDhSecret = Just dhSecret} <- withTransaction store getSavedNtfToken
Right code <- pure $ NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
withTransaction store $ \db ->
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_status = ?, tkn_action = ?
WHERE provider = ? AND device_token = ?
|]
(NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString)
Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTActive <- registerNtfToken a' tkn NMPeriodic
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a ->
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, and client might have lost verification notification.
-- so that repeat registration happens when client is restarted.
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
-- this emulates the situation when server registered token but the client did not receive the response
withTransaction store $ \db ->
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ?
WHERE provider = ? AND device_token = ?
|]
(NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString)
Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, and client might have lost verification notification.
-- so that repeat registration happens when client is restarted.
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
getTestNtfTokenPort :: AgentClient -> AE String
getTestNtfTokenPort a =
ExceptT (runExceptT (withStore' a getSavedNtfToken) `runReaderT` agentEnv a) >>= \case
Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
Nothing -> error "no active NtfToken"
testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
withNtfServerThreadOn t ntfTestPort $ \ntf ->
withNtfServerThreadOn t ntfTestPort2 $ \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}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
-- shut down the "other" server
port <- getTestNtfTokenPort a
liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
-- still works
NTActive <- checkNtfToken a tkn
liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
-- negative test, the correct server is now gone
Left _ <- tryError (checkNtfToken a tkn)
pure ()
testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers t APNSMockServer {apnsQ} =
withNtfServerThreadOn t ntfTestPort $ \ntf -> do
tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
tkn <- registerTestToken a "abcd" NMInstant apnsQ
NTActive <- checkNtfToken a tkn
liftIO $ setNtfServers a [testNtfServer2]
NTActive <- checkNtfToken a tkn -- still works on old server
pure tkn
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a -> do
runRight_ $ do
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
NTActive <- checkNtfToken a tkn1
liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
-- trigger token replace
tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
deleteNtfToken a tkn2 -- force server switch
Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
killThread ntf
withNtfServerOn t ntfTestPort2 $ runRight_ $ do
liftIO $ threadDelay 1000000 -- for notification server to reconnect
tkn <- registerTestToken a "qwer" NMInstant apnsQ
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
testRunNTFServerTests t srv =
withNtfServerOn t ntfTestPort $
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} 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
(aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken alice tkn NMInstant
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
vNonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken alice tkn vNonce verification
NTActive <- checkNtfToken alice tkn
-- send message
liftIO $ threadDelay 250000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
-- notification
(nonce, message) <- messageNotification apnsQ
pure (bobId, aliceId, nonce, message)
-- alice client already has subscription for the connection
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
threadDelay 500000
suspendAgent alice 0
closeSQLiteStore store
threadDelay 1000000
-- aliceNtf client doesn't have subscription and is allowed to get notification message
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
pure ()
threadDelay 1000000
reopenSQLiteStore store
foregroundAgent alice
threadDelay 500000
runRight_ $ do
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
-- delete notification subscription
toggleConnectionNtfs alice bobId False
liftIO $ threadDelay 500000
-- send message
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT $ baseId + 2)
-- no notifications should follow
noNotification apnsQ
where
msgId = subtract baseId
testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob =
runRight_ $ do
-- alice registers notification token
DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
-- bob registers notification token
DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ
-- establish connection
liftIO $ threadDelay 50000
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
liftIO $ threadDelay 1000000
(aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ threadDelay 750000
void $ messageNotificationData alice apnsQ
("", _, CONF confId _ "bob's connInfo") <- get alice
liftIO $ threadDelay 500000
allowConnection alice bobId confId "alice's connInfo"
void $ messageNotificationData bob apnsQ
get bob ##> ("", aliceId, INFO "alice's connInfo")
when (baseId == 3) $ void $ messageNotificationData alice apnsQ
get alice ##> ("", bobId, CON)
when (baseId == 3) $ void $ messageNotificationData bob apnsQ
get bob ##> ("", aliceId, CON)
-- bob sends message
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
-- alice sends message
2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
get alice ##> ("", bobId, SENT $ baseId + 2)
void $ messageNotificationData bob apnsQ
get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
ackMessage bob aliceId (baseId + 2) Nothing
-- no unexpected notifications should follow
noNotification apnsQ
where
msgId = subtract baseId
registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
registerTestToken a token mode apnsQ = do
let tkn = DeviceToken PPApnsTest token
NTRegistered <- registerNtfToken a tkn mode
Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
timeout 1000000 . atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
verifyNtfToken a tkn nonce' verification'
NTActive <- checkNtfToken a tkn
pure tkn
testChangeNotificationsMode :: APNSMockServer -> IO ()
testChangeNotificationsMode APNSMockServer {apnsQ} =
withAgentClients2 $ \alice bob -> runRight_ $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token, set mode to NMInstant
tkn <- registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
-- set mode to NMPeriodic
NTActive <- registerNtfToken alice tkn NMPeriodic
-- send message, no notification
liftIO $ threadDelay 750000
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT $ baseId + 2)
noNotification apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 2) Nothing
-- set mode to NMInstant
NTActive <- registerNtfToken alice tkn NMInstant
-- send message, receive notification
liftIO $ threadDelay 500000
3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
get bob ##> ("", aliceId, SENT $ baseId + 3)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 3) Nothing
-- turn off notifications
deleteNtfToken alice tkn
-- send message, no notification
liftIO $ threadDelay 500000
4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there"
get bob ##> ("", aliceId, SENT $ baseId + 4)
noNotification apnsQ
get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
-- turn on notifications, set mode to NMInstant
void $ registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
get bob ##> ("", aliceId, SENT $ baseId + 5)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 5) Nothing
-- no notifications should follow
noNotification apnsQ
where
baseId = 1
msgId = subtract baseId
testChangeToken :: APNSMockServer -> IO ()
testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
(aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token, set mode to NMInstant
void $ registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
pure (aliceId, bobId)
withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do
subscribeConnection alice1 bobId
-- change notification token
void $ registerTestToken alice1 "bcde" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
get bob ##> ("", aliceId, SENT $ baseId + 2)
void $ messageNotificationData alice1 apnsQ
get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
ackMessage alice1 bobId (baseId + 2) Nothing
-- no notifications should follow
noNotification apnsQ
where
baseId = 1
msgId = subtract baseId
testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
(aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 2)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 2 Nothing
liftIO $ killThread threadId
pure (aliceId, bobId)
liftIO $ threadDelay 250000
withNtfServerStoreLog t $ \threadId -> runRight_ $ do
liftIO $ threadDelay 250000
3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 3)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 2)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 2 Nothing
liftIO $ killThread threadId
pure (aliceId, bobId)
runRight_ @AgentErrorType $ do
nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do
nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
liftIO $ threadDelay 1000000
3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 3)
_ <- messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
threadDelay 1000000
conns <- runServers $ do
conns <- replicateM (n :: Int) $ makeConnection a b
_ <- registerTestToken a "abcd" NMInstant apnsQ
liftIO $ threadDelay 5000000
forM_ conns $ \(aliceId, bobId) -> do
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
get b ##> ("", aliceId, SENT msgId)
void $ messageNotificationData a apnsQ
get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage a bobId msgId Nothing
pure conns
runRight_ @AgentErrorType $ do
("", "", DOWN _ bcs1) <- nGet a
("", "", DOWN _ bcs2) <- nGet a
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
("", "", DOWN _ acs1) <- nGet b
("", "", DOWN _ acs2) <- nGet b
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
runServers $ do
("", "", UP _ bcs1) <- nGet a
("", "", UP _ bcs2) <- nGet a
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
("", "", UP _ acs1) <- nGet b
("", "", UP _ acs2) <- nGet b
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
liftIO $ threadDelay 1500000
forM_ conns $ \(aliceId, bobId) -> do
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
get b ##> ("", aliceId, SENT msgId)
_ <- messageNotificationData a apnsQ
get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
where
runServers :: ExceptT AgentErrorType IO a -> IO a
runServers a = do
withSmpServerStoreLogOn t testPort $ \t1 -> do
res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
runRight a `finally` killThread t2
killThread t1
pure res
testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications servers APNSMockServer {apnsQ} =
withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
(aId, bId) <- makeConnection a b
exchangeGreetings a bId b aId
_ <- registerTestToken a "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
let testMessage msg = do
msgId <- sendMessage b aId (SMP.MsgFlags True) msg
get b ##> ("", aId, SENT msgId)
void $ messageNotificationData a apnsQ
get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
ackMessage a bId msgId Nothing
testMessage "hello"
_ <- switchConnectionAsync a "" bId
switchComplete a bId b aId
liftIO $ threadDelay 500000
testMessage "hello again"
testNotificationsOldToken :: APNSMockServer -> IO ()
testNotificationsOldToken APNSMockServer {apnsQ} =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
let testMessageAB = testMessage_ apnsQ a abId b baId
_ <- registerTestToken a "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
testMessageAB "hello"
-- change server
liftIO $ setNtfServers a [testNtfServer2] -- server 2 isn't running now, don't use
-- replacing token keeps server
_ <- registerTestToken a "xyzw" NMInstant apnsQ
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
testMessageAB "still there"
-- new connections keep server
(acId, caId) <- makeConnection a c
let testMessageAC = testMessage_ apnsQ a acId c caId
testMessageAC "greetings"
testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
testNotificationsNewToken APNSMockServer {apnsQ} oldNtf =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
let testMessageAB = testMessage_ apnsQ a abId b baId
tkn <- registerTestToken a "abcd" NMInstant apnsQ
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
liftIO $ threadDelay 250000
testMessageAB "hello"
-- switch
liftIO $ setNtfServers a [testNtfServer2]
deleteNtfToken a tkn
_ <- registerTestToken a "abcd" NMInstant apnsQ
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort2
liftIO $ threadDelay 250000
liftIO $ killThread oldNtf
-- -- back to work
testMessageAB "hello again"
(acId, caId) <- makeConnection a c
let testMessageAC = testMessage_ apnsQ a acId c caId
testMessageAC "greetings"
testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
testMessage_ apnsQ a aId b bId msg = do
msgId <- sendMessage b aId (SMP.MsgFlags True) msg
get b ##> ("", aId, SENT msgId)
void $ messageNotificationData a apnsQ
get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
ackMessage a bId msgId Nothing
messageNotification :: HasCallStack => TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
messageNotification apnsQ = do
1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
Nothing -> error "no notification"
Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
nonce <- C.cbNonce <$> ntfData .-> "nonce"
message <- ntfData .-> "message"
liftIO $ sendApnsResponse APNSRespOk
pure (nonce, message)
_ -> error "bad notification"
messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
messageNotificationData c apnsQ = do
(nonce, message) <- messageNotification apnsQ
NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
pure pnMsgData
noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
noNotification apnsQ = do
500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
Nothing -> pure ()
_ -> error "unexpected notification"
Reference in New Issue View Git Blame Copy Permalink