diff --git a/simplexmq.cabal b/simplexmq.cabal index f637aa41d..43e18ff5c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -174,6 +174,7 @@ library Simplex.Messaging.Server.Main Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore.STM + Simplex.Messaging.Server.NtfStore Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.QueueInfo Simplex.Messaging.Server.QueueStore.STM diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 54be77a71..42c24aeb8 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -220,9 +220,8 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge NtfPushServer {pushQ} <- asks pushServer stats <- asks serverStats liftIO $ updatePeriodStats (activeSubs stats) ntfId - atomically $ - findNtfSubscriptionToken st smpQueue - >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| []))) + atomically (findNtfSubscriptionToken st smpQueue) + >>= mapM_ (\tkn -> atomically (writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| [])))) incNtfStat ntfReceived Right SMP.END -> whenM (atomically $ activeClientSession' ca sessionId srv) $ diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index bf96b6deb..54fef3ab3 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -58,7 +58,7 @@ import Data.IORef import Data.Int (Int64) import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS -import Data.List (intercalate, mapAccumR) +import Data.List (foldl', intercalate, mapAccumR) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M @@ -88,6 +88,7 @@ import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.STM as QS @@ -137,13 +138,16 @@ smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M () smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do s <- asks server pa <- asks proxyAgent - expired <- restoreServerMessages - restoreServerStats expired + expiredMsgs <- restoreServerMessages + expiredNtfs <- restoreServerNtfs + restoreServerStats expiredMsgs expiredNtfs raceAny_ ( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ()) + : deliverNtfsThread s : sendPendingEvtsThread s : receiveFromProxyAgent pa + : expireNtfsThread cfg : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg ) `finally` withLock' (savingLock s) "final" (saveServer False >> closeServer) @@ -171,7 +175,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey saveServer :: Bool -> M () - saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats + saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerNtfs >> saveServerStats closeServer :: M () closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent @@ -230,6 +234,31 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT -- remove client from server's subscribed cients removeWhenNoSubs c = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c) + deliverNtfsThread :: Server -> M () + deliverNtfsThread Server {ntfSubClients} = do + ntfInt <- asks $ ntfDeliveryInterval . config + ns <- asks ntfStore + stats <- asks serverStats + liftIO $ forever $ do + threadDelay ntfInt + readTVarIO ntfSubClients >>= mapM_ (deliverNtfs ns stats) + where + deliverNtfs ns stats Client {clientId, ntfSubscriptions, sndQ, connected} = whenM currentClient $ + readTVarIO ntfSubscriptions >>= \subs -> do + ts_ <- foldM addNtfs [] (M.keys subs) + mapM_ (atomically . writeTBQueue sndQ) $ L.nonEmpty ts_ + updateNtfStats $ length ts_ + where + currentClient = (&&) <$> readTVarIO connected <*> (IM.member clientId <$> readTVarIO ntfSubClients) + addNtfs :: [Transmission BrokerMsg] -> NotifierId -> IO [Transmission BrokerMsg] + addNtfs acc nId = + (foldl' (\acc' ntf -> nmsg nId ntf : acc') acc) -- reverses, to order by time + <$> flushNtfs ns nId + nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (CorrId "", nId, NMSG ntfNonce ntfEncMeta) + updateNtfStats len = when (len > 0) $ liftIO $ do + atomicModifyIORef'_ (msgNtfs stats) (+ len) + atomicModifyIORef'_ (msgNtfsB stats) (+ (len `div` 80 + 1)) -- up to 80 NMSG in the batch + sendPendingEvtsThread :: Server -> M () sendPendingEvtsThread s = do endInt <- asks $ pendingENDInterval . config @@ -259,8 +288,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT updateEndStats = do stats <- asks serverStats let len = L.length qEvts - liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len) - liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch + when (len > 0) $ liftIO $ do + atomicModifyIORef'_ (qSubEnd stats) (+ len) + atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch receiveFromProxyAgent :: ProxyAgent -> M () receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} = @@ -294,6 +324,18 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT deleted <- liftIO $ deleteExpiredMsgs q old liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + expireNtfsThread :: ServerConfig -> M () + expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do + ns <- asks ntfStore + let interval = checkInterval expCfg * 1000000 + stats <- asks serverStats + labelMyThread "expireNtfsThread" + liftIO $ forever $ do + threadDelay' interval + old <- expireBeforeEpoch expCfg + expired <- deleteExpiredNtfs ns old + when (expired > 0) $ atomicModifyIORef'_ (msgNtfExpired stats) (+ expired) + serverStatsThread_ :: ServerConfig -> [M ()] serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = [logServerStats logStatsStartTime interval serverStatsLogFile] @@ -351,8 +393,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT msgRecvNtf' <- atomicSwapIORef msgRecvNtf 0 psNtf <- liftIO $ periodStatCounts activeQueuesNtf ts msgNtfs' <- atomicSwapIORef (msgNtfs ss) 0 + msgNtfsB' <- atomicSwapIORef (msgNtfsB ss) 0 msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0 msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0 + msgNtfExpired' <- atomicSwapIORef (msgNtfExpired ss) 0 pRelays' <- getResetProxyStatsData pRelays pRelaysOwn' <- getResetProxyStatsData pRelaysOwn pMsgFwds' <- getResetProxyStatsData pMsgFwds @@ -424,7 +468,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT show qSubEnd', show qSubEndB', show ntfDeletedB', - show ntfSubB' + show ntfSubB', + show msgNtfsB', + show msgNtfExpired' ] ) liftIO $ threadDelay' interval @@ -534,6 +580,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT hPutStrLn h $ "other GET events (auth, duplicate, prohibited): " <> show gets putStat "msgSentNtf" msgSentNtf putStat "msgRecvNtf" msgRecvNtf + putStat "msgNtfs" msgNtfs + putStat "msgNtfsB" msgNtfsB + putStat "msgNtfExpired" msgNtfExpired putStat "qCount" qCount putStat "msgCount" msgCount putProxyStat "pRelays" pRelays @@ -932,7 +981,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M () -client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do +client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" forever $ atomically (readTBQueue rcvQ) @@ -1135,6 +1184,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s liftIO (deleteQueueNotifier st entId) >>= \case Right (Just nId) -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it + asks ntfStore >>= liftIO . (`deleteNtfs` nId) atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False) incStat . ntfDeleted =<< asks serverStats pure ok @@ -1276,7 +1326,14 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s Message {msgFlags} -> do stats <- asks serverStats incStat $ msgRecv stats - when isGet $ incStat $ msgRecvGet stats + if isGet + then incStat $ msgRecvGet stats + else pure () -- TODO skip notification delivery for delivered message + -- skipping delivery fails tests, it should be counted in msgNtfSkipped + -- forM_ (notifierId <$> notifier qr) $ \nId -> do + -- ns <- asks ntfStore + -- atomically $ TM.lookup nId ns >>= + -- mapM_ (\MsgNtf {ntfMsgId} -> when (msgId == msgId') $ TM.delete nId ns) liftIO $ atomicModifyIORef'_ (msgCount stats) (subtract 1) liftIO $ updatePeriodStats (activeQueues stats) entId when (notification msgFlags) $ do @@ -1310,7 +1367,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s Just (msg, wasEmpty) -> time "SEND ok" $ do when wasEmpty $ liftIO $ tryDeliverMessage msg when (notification msgFlags) $ do - mapM_ (`trySendNotification` msg) (notifier qr) + mapM_ (`enqueueNotification` msg) (notifier qr) incStat $ msgSentNtf stats liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) incStat $ msgSent stats @@ -1395,39 +1452,20 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s deliver q s writeTVar st NoSub - trySendNotification :: NtfCreds -> Message -> M () - trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg = do - stats <- asks serverStats - liftIO (TM.lookupIO notifierId notifiers) >>= \case - Nothing -> do - incStat $ msgNtfNoSub stats - logWarn "No notification subscription" - Just ntfClnt -> do - let updateStats True = incStat $ msgNtfs stats - updateStats _ = do - incStat $ msgNtfLost stats - logWarn "Dropped message notification" - writeNtf notifierId msg rcvNtfDhSecret ntfClnt >>= mapM_ updateStats + enqueueNotification :: NtfCreds -> Message -> M () + enqueueNotification _ MessageQuota {} = pure () + enqueueNotification NtfCreds {notifierId = nId, rcvNtfDhSecret} Message {msgId, msgTs} = do + -- stats <- asks serverStats + ns <- asks ntfStore + ntf <- mkMessageNotification msgId msgTs rcvNtfDhSecret + liftIO $ storeNtf ns nId ntf - writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar Client -> M (Maybe Bool) - writeNtf nId msg rcvNtfDhSecret ntfClnt = case msg of - Message {msgId, msgTs} -> Just <$> do - (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret - -- must be in one STM transaction to avoid the queue becoming full between the check and writing - atomically $ do - Client {sndQ = q} <- readTVar ntfClnt - ifM - (isFullTBQueue q) - (pure $ False) - (True <$ writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]) - _ -> pure Nothing - - mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M (C.CbNonce, EncNMsgMeta) + mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M MsgNtf mkMessageNotification msgId msgTs rcvNtfDhSecret = do - cbNonce <- atomically . C.randomCbNonce =<< asks random + ntfNonce <- atomically . C.randomCbNonce =<< asks random let msgMeta = NMsgMeta {msgId, msgTs} - encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128 - pure . (cbNonce,) $ fromRight "" encNMsgMeta + encNMsgMeta = C.cbEncrypt rcvNtfDhSecret ntfNonce (smpEncode msgMeta) 128 + pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta} processForwardedCommand :: EncFwdTransmission -> M BrokerMsg processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do @@ -1528,9 +1566,10 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s -- queue is usually deleted by the same client that is currently subscribed, -- we delete subscription here, so the client with no subscriptions can be disconnected. TM.delete entId subscriptions - forM_ (notifierId <$> notifier q) $ \nId -> + forM_ (notifierId <$> notifier q) $ \nId -> do -- queue is deleted by a different client from the one subscribed to notifications, -- so we don't need to remove subscription from the current client. + asks ntfStore >>= liftIO . (`deleteNtfs` nId) atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False) updateDeletedStats q pure ok @@ -1657,6 +1696,50 @@ restoreServerMessages = msgErr :: Show e => String -> e -> String msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) +saveServerNtfs :: M () +saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs + where + saveNtfs f = do + logInfo $ "saving notifications to file " <> T.pack f + NtfStore ns <- asks ntfStore + liftIO . withFile f WriteMode $ \h -> + readTVarIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs + logInfo "notifications saved" + where + -- reverse on save, to save notifications in order, will become reversed again when restoring. + saveQueueNtfs h (nId, v) = BLD.hPutBuilder h . encodeNtfs nId . reverse =<< readTVarIO v + encodeNtfs nId = mconcat . map (\ntf -> BLD.byteString (strEncode $ NLRv1 nId ntf) <> BLD.char8 '\n') + +restoreServerNtfs :: M Int +restoreServerNtfs = + asks (storeNtfsFile . config) >>= \case + Just f -> ifM (doesFileExist f) (restoreNtfs f) (pure 0) + Nothing -> pure 0 + where + restoreNtfs f = do + logInfo $ "restoring notifications from file " <> T.pack f + ns <- asks ntfStore + old <- asks (notificationExpiration . config) >>= liftIO . expireBeforeEpoch + runExceptT (liftIO (LB.readFile f) >>= foldM (restoreNtf ns old) 0 . LB.lines) >>= \case + Left e -> do + logError . T.pack $ "error restoring notifications: " <> e + liftIO exitFailure + Right expired -> do + renameFile f $ f <> ".bak" + logInfo "notifications restored" + pure expired + where + restoreNtf ns old !expired s' = do + NLRv1 nId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s + liftIO $ addToNtfs nId ntf + where + s = LB.toStrict s' + addToNtfs nId ntf@MsgNtf {ntfTs} + | systemSeconds ntfTs < old = pure (expired + 1) + | otherwise = storeNtf ns nId ntf $> expired + ntfErr :: Show e => String -> e -> String + ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) + saveServerStats :: M () saveServerStats = asks (serverStatsBackupFile . config) @@ -1667,8 +1750,8 @@ saveServerStats = B.writeFile f $ strEncode stats logInfo "server stats saved" -restoreServerStats :: Int -> M () -restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats +restoreServerStats :: Int -> Int -> M () +restoreServerStats expiredMsgs expiredNtfs = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats where restoreStats f = whenM (doesFileExist f) $ do logInfo $ "restoring server stats from file " <> T.pack f @@ -1677,7 +1760,7 @@ restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config) s <- asks serverStats _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore _msgCount <- liftIO . foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 =<< readTVarIO =<< asks msgStore - liftIO $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring} + liftIO $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredMsgs, _msgNtfExpired = _msgNtfExpired d + expiredNtfs} renameFile f $ f <> ".bak" logInfo "server stats restored" when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 05ed7da53..a485ab73e 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -38,6 +38,7 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..)) import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.Stats @@ -61,6 +62,7 @@ data ServerConfig = ServerConfig msgIdBytes :: Int, storeLogFile :: Maybe FilePath, storeMsgsFile :: Maybe FilePath, + storeNtfsFile :: Maybe FilePath, -- | set to False to prohibit creating new queues allowNewQueues :: Bool, -- | simple password that the clients need to pass in handshake to be able to create new queues @@ -70,6 +72,8 @@ data ServerConfig = ServerConfig controlPortAdminAuth :: Maybe BasicAuth, -- | time after which the messages can be removed from the queues and check interval, seconds messageExpiration :: Maybe ExpirationConfig, + -- | notification expiration interval (seconds) + notificationExpiration :: ExpirationConfig, -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING), -- and check interval, seconds inactiveClientExpiration :: Maybe ExpirationConfig, @@ -82,6 +86,8 @@ data ServerConfig = ServerConfig serverStatsLogFile :: FilePath, -- | file to save and restore stats serverStatsBackupFile :: Maybe FilePath, + -- | notification delivery interval + ntfDeliveryInterval :: Int, -- | interval between sending pending END events to unsubscribed clients, seconds pendingENDInterval :: Int, smpCredentials :: ServerCredentials, @@ -110,6 +116,16 @@ defaultMessageExpiration = checkInterval = 43200 -- seconds, 12 hours } +defNtfExpirationHours :: Int64 +defNtfExpirationHours = 24 + +defaultNtfExpiration :: ExpirationConfig +defaultNtfExpiration = + ExpirationConfig + { ttl = defNtfExpirationHours * 3600, -- seconds + checkInterval = 3600 -- seconds, 1 hour + } + defaultInactiveClientExpiration :: ExpirationConfig defaultInactiveClientExpiration = ExpirationConfig @@ -127,6 +143,7 @@ data Env = Env serverIdentity :: KeyHash, queueStore :: QueueStore, msgStore :: STMMsgStore, + ntfStore :: NtfStore, random :: TVar ChaChaDRG, storeLog :: Maybe (StoreLog 'WriteMode), tlsServerCreds :: T.Credential, @@ -229,6 +246,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg server <- newServer queueStore <- newQueueStore msgStore <- newMsgStore + ntfStore <- NtfStore <$> TM.emptyIO random <- C.newRandom storeLog <- forM storeLogFile $ \f -> do @@ -244,7 +262,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg clientSeq <- newTVarIO 0 clients <- newTVarIO mempty proxyAgent <- newSMPProxyAgent smpAgentCfg random - pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent} + pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, ntfStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent} where getCredentials protocol creds = do files <- missingCreds diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index bcd96c170..ca4a5ed60 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -38,7 +38,7 @@ import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) import Simplex.Messaging.Server (AttachHTTP, runSMPServer) import Simplex.Messaging.Server.CLI -import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency) +import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange) @@ -154,7 +154,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\ \# they are preserved in the .bak file until the next restart.\n" <> ("restore_messages: " <> onOff enableStoreLog <> "\n") - <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n\n") + <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n") + <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n") <> "# Log daily server statistics to CSV file\n" <> ("log_stats: " <> onOff logStats <> "\n\n") <> "[AUTH]\n\ @@ -268,6 +269,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) + restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of + Just True -> Just path + Just False -> Nothing + -- if the setting is not set, it is enabled when store log is enabled + _ -> enableStoreLog $> path transports = iniTransports ini sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports serverConfig = @@ -286,13 +292,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams', storeLogFile = enableStoreLog $> storeLogFilePath, - storeMsgsFile = - let messagesPath = combine logPath "smp-server-messages.log" - in case iniOnOff "STORE_LOG" "restore_messages" ini of - Just True -> Just messagesPath - Just False -> Nothing - -- if the setting is not set, it is enabled when store log is enabled - _ -> enableStoreLog $> messagesPath, + storeMsgsFile = restoreMessagesFile $ combine logPath "smp-server-messages.log", + storeNtfsFile = restoreMessagesFile $ combine logPath "smp-server-ntfs.log", -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini, @@ -303,6 +304,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = defaultMessageExpiration { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini }, + notificationExpiration = + defaultNtfExpiration + { ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini + }, inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini $> ExpirationConfig @@ -314,6 +319,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = serverStatsLogFile = combine logPath "smp-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", pendingENDInterval = 15000000, -- 15 seconds + ntfDeliveryInterval = 3000000, -- 3 seconds smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs new file mode 100644 index 000000000..ded2bd85d --- /dev/null +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Server.NtfStore where + +import Control.Concurrent.STM +import Control.Monad (foldM) +import Data.Int (Int64) +import qualified Data.Map.Strict as M +import Data.Time.Clock.System (SystemTime (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM + +newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf])) + +data MsgNtf = MsgNtf + { ntfMsgId :: MsgId, + ntfTs :: SystemTime, + ntfNonce :: C.CbNonce, + ntfEncMeta :: EncNMsgMeta + } + +storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO () +storeNtf (NtfStore ns) nId ntf = do + TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :)) + -- TODO coalesce messages here once the client is updated to process multiple messages + -- for single notification. + -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats + where + newNtfs = TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :)) + +deleteNtfs :: NtfStore -> NotifierId -> IO () +deleteNtfs (NtfStore ns) nId = atomically $ TM.delete nId ns + +flushNtfs :: NtfStore -> NotifierId -> IO [MsgNtf] +flushNtfs (NtfStore ns) nId = do + TM.lookupIO nId ns >>= maybe (pure []) swapNtfs + where + swapNtfs v = + readTVarIO v >>= \case + [] -> pure [] + -- if notifications available, atomically swap with empty array + _ -> atomically (swapTVar v []) + +deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int +deleteExpiredNtfs (NtfStore ns) old = + foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns + where + expireQueue nId = TM.lookupIO nId ns >>= maybe (pure 0) expire + expire v = readTVarIO v >>= \case + [] -> pure 0 + _ -> + atomically $ readTVar v >>= \case + [] -> pure 0 + -- check the last message first, it is the earliest + ntfs | systemSeconds (ntfTs $ last $ ntfs) < old -> do + let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs + writeTVar v ntfs' + pure $! length ntfs - length ntfs' + _ -> pure 0 + +data NtfLogRecord = NLRv1 NotifierId MsgNtf + +instance StrEncoding MsgNtf where + strEncode MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta} = strEncode (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta) + strP = do + (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta) <- strP + pure MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta} + +instance StrEncoding NtfLogRecord where + strEncode (NLRv1 nId ntf) = strEncode (Str "v1", nId, ntf) + strP = "v1 " *> (NLRv1 <$> strP_ <*> strP) diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index 097ddb607..49078d2d9 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -67,8 +67,10 @@ data ServerStats = ServerStats msgRecvNtf :: IORef Int, -- received messages with NTF flag activeQueuesNtf :: PeriodStats, msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf) + msgNtfsB :: IORef Int, -- messages notication batches delivered to NTF server msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected) msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full + msgNtfExpired :: IORef Int, -- expired pRelays :: ProxyStats, pRelaysOwn :: ProxyStats, pMsgFwds :: ProxyStats, @@ -117,8 +119,10 @@ data ServerStatsData = ServerStatsData _msgRecvNtf :: Int, _activeQueuesNtf :: PeriodStatsData, _msgNtfs :: Int, + _msgNtfsB :: Int, _msgNtfNoSub :: Int, _msgNtfLost :: Int, + _msgNtfExpired :: Int, _pRelays :: ProxyStatsData, _pRelaysOwn :: ProxyStatsData, _pMsgFwds :: ProxyStatsData, @@ -169,8 +173,10 @@ newServerStats ts = do msgRecvNtf <- newIORef 0 activeQueuesNtf <- newPeriodStats msgNtfs <- newIORef 0 + msgNtfsB <- newIORef 0 msgNtfNoSub <- newIORef 0 msgNtfLost <- newIORef 0 + msgNtfExpired <- newIORef 0 pRelays <- newProxyStats pRelaysOwn <- newProxyStats pMsgFwds <- newProxyStats @@ -218,8 +224,10 @@ newServerStats ts = do msgRecvNtf, activeQueuesNtf, msgNtfs, + msgNtfsB, msgNtfNoSub, msgNtfLost, + msgNtfExpired, pRelays, pRelaysOwn, pMsgFwds, @@ -269,8 +277,10 @@ getServerStatsData s = do _msgRecvNtf <- readIORef $ msgRecvNtf s _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s _msgNtfs <- readIORef $ msgNtfs s + _msgNtfsB <- readIORef $ msgNtfsB s _msgNtfNoSub <- readIORef $ msgNtfNoSub s _msgNtfLost <- readIORef $ msgNtfLost s + _msgNtfExpired <- readIORef $ msgNtfExpired s _pRelays <- getProxyStatsData $ pRelays s _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s _pMsgFwds <- getProxyStatsData $ pMsgFwds s @@ -318,8 +328,10 @@ getServerStatsData s = do _msgRecvNtf, _activeQueuesNtf, _msgNtfs, + _msgNtfsB, _msgNtfNoSub, _msgNtfLost, + _msgNtfExpired, _pRelays, _pRelaysOwn, _pMsgFwds, @@ -370,8 +382,10 @@ setServerStats s d = do writeIORef (msgRecvNtf s) $! _msgRecvNtf d setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d) writeIORef (msgNtfs s) $! _msgNtfs d + writeIORef (msgNtfsB s) $! _msgNtfsB d writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d writeIORef (msgNtfLost s) $! _msgNtfLost d + writeIORef (msgNtfExpired s) $! _msgNtfExpired d setProxyStats (pRelays s) $! _pRelays d setProxyStats (pRelaysOwn s) $! _pRelaysOwn d setProxyStats (pMsgFwds s) $! _pMsgFwds d @@ -420,8 +434,10 @@ instance StrEncoding ServerStatsData where "msgSentNtf=" <> strEncode (_msgSentNtf d), "msgRecvNtf=" <> strEncode (_msgRecvNtf d), "msgNtfs=" <> strEncode (_msgNtfs d), + "msgNtfsB=" <> strEncode (_msgNtfsB d), "msgNtfNoSub=" <> strEncode (_msgNtfNoSub d), "msgNtfLost=" <> strEncode (_msgNtfLost d), + "msgNtfExpired=" <> strEncode (_msgNtfExpired d), "activeQueues:", strEncode (_activeQueues d), "activeQueuesNtf:", @@ -475,8 +491,10 @@ instance StrEncoding ServerStatsData where _msgSentNtf <- opt "msgSentNtf=" _msgRecvNtf <- opt "msgRecvNtf=" _msgNtfs <- opt "msgNtfs=" + _msgNtfsB <- opt "msgNtfsB=" _msgNtfNoSub <- opt "msgNtfNoSub=" _msgNtfLost <- opt "msgNtfLost=" + _msgNtfExpired <- opt "msgNtfExpired=" _activeQueues <- optional ("activeQueues:" <* A.endOfLine) >>= \case Just _ -> strP <* optional A.endOfLine @@ -536,8 +554,10 @@ instance StrEncoding ServerStatsData where _msgSentNtf, _msgRecvNtf, _msgNtfs, + _msgNtfsB, _msgNtfNoSub, _msgNtfLost, + _msgNtfExpired, _activeQueues, _activeQueuesNtf, _pRelays, diff --git a/src/Simplex/Messaging/TMap.hs b/src/Simplex/Messaging/TMap.hs index 1bc9bcb60..02d20b695 100644 --- a/src/Simplex/Messaging/TMap.hs +++ b/src/Simplex/Messaging/TMap.hs @@ -9,6 +9,7 @@ module Simplex.Messaging.TMap member, memberIO, insert, + insertM, delete, lookupInsert, lookupDelete, @@ -62,6 +63,10 @@ insert :: Ord k => k -> a -> TMap k a -> STM () insert k v m = modifyTVar' m $ M.insert k v {-# INLINE insert #-} +insertM :: Ord k => k -> STM a -> TMap k a -> STM () +insertM k f m = modifyTVar' m . M.insert k =<< f +{-# INLINE insertM #-} + delete :: Ord k => k -> TMap k a -> STM () delete k m = modifyTVar' m $ M.delete k {-# INLINE delete #-} diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 40071873c..272c6d6d6 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -54,7 +54,7 @@ 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 SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) 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) @@ -134,9 +134,8 @@ notificationTests t = do withNtfServer t $ testChangeToken apns describe "Notifications server store log" $ it "should save and restore tokens and subscriptions" $ - withSmpServer t $ - withAPNSMockServer $ \apns -> - testNotificationsStoreLog t apns + withAPNSMockServer $ \apns -> + testNotificationsStoreLog t apns describe "Notifications after SMP server restart" $ it "should resume subscriptions after SMP server is restarted" $ withAPNSMockServer $ \apns -> @@ -183,15 +182,14 @@ runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do threadDelay 100000 testNotificationToken :: APNSMockServer -> IO () -testNotificationToken APNSMockServer {apnsQ} = do +testNotificationToken apns = 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" - liftIO $ sendApnsResponse APNSRespOk verifyNtfToken a tkn nonce verification NTActive <- checkNtfToken a tkn deleteNtfToken a tkn @@ -208,48 +206,44 @@ v .-> key = do -- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} testNtfTokenRepeatRegistration :: APNSMockServer -> IO () -testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do +testNtfTokenRepeatRegistration apns = 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + getMockNotification apns tkn _ <- 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} = +testNtfTokenSecondRegistration apns = -- 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + getMockNotification apns tkn verification' <- ntfData' .-> "verification" nonce' <- C.cbNonce <$> ntfData' .-> "nonce" - liftIO $ sendApnsResponse' APNSRespOk -- at this point the first token is still active NTActive <- checkNtfToken a tkn @@ -265,14 +259,13 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = pure () testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO () -testNtfTokenServerRestart t APNSMockServer {apnsQ} = do +testNtfTokenServerRestart t apns = 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 + APNSMockRequest {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 threadDelay 1000000 @@ -287,14 +280,13 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do pure () testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do +testNtfTokenServerRestartReverify t apns = 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn pure ntfData runRight_ $ do verification <- ntfData .-> "verification" @@ -311,14 +303,13 @@ testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do pure () testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do +testNtfTokenServerRestartReverifyTimeout t apns = 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification @@ -347,14 +338,14 @@ testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do pure () testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do +testNtfTokenServerRestartReregister t apns = 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 + APNSMockRequest {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 threadDelay 1000000 withAgent 2 agentCfg initAgentServers testDB $ \a' -> @@ -362,9 +353,8 @@ testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do -- 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification @@ -372,14 +362,14 @@ testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do pure () testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO () -testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do +testNtfTokenServerRestartReregisterTimeout t apns = 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 + APNSMockRequest {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 withTransaction store $ \db -> DB.execute @@ -398,9 +388,8 @@ testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do -- 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification @@ -414,18 +403,17 @@ getTestNtfTokenPort a = Nothing -> error "no active NtfToken" testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO () -testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do +testNtfTokenMultipleServers t apns = 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn 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 @@ -439,10 +427,10 @@ testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do pure () testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO () -testNtfTokenChangeServers t APNSMockServer {apnsQ} = +testNtfTokenChangeServers t apns = withNtfServerThreadOn t ntfTestPort $ \ntf -> do tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do - tkn <- registerTestToken a "abcd" NMInstant apnsQ + tkn <- registerTestToken a "abcd" NMInstant apns NTActive <- checkNtfToken a tkn liftIO $ setNtfServers a [testNtfServer2] NTActive <- checkNtfToken a tkn -- still works on old server @@ -457,15 +445,15 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} = 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 + tkn2 <- registerTestToken a "xyzw" NMInstant apns 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 + Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apns -- 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 + tkn <- registerTestToken a "qwer" NMInstant apns checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) @@ -475,7 +463,7 @@ testRunNTFServerTests t srv = 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 +testNotificationSubscriptionExistingConnection 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 @@ -488,11 +476,10 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali -- 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 + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn verification <- ntfData .-> "verification" vNonce <- C.cbNonce <$> ntfData .-> "nonce" - liftIO $ sendApnsResponse APNSRespOk verifyNtfToken alice tkn vNonce verification NTActive <- checkNtfToken alice tkn -- send message @@ -500,7 +487,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" get bob ##> ("", aliceId, SENT $ baseId + 1) -- notification - (nonce, message) <- messageNotification apnsQ + (nonce, message) <- messageNotification apns tkn pure (bobId, aliceId, nonce, message) -- alice client already has subscription for the connection @@ -533,65 +520,64 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali 2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT $ baseId + 2) -- no notifications should follow - noNotification apnsQ + noNotification alice apns where msgId = subtract baseId testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob = +testNotificationSubscriptionNewConnection apns baseId alice bob = runRight_ $ do -- alice registers notification token - DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ + DeviceToken {} <- registerTestToken alice "abcd" NMInstant apns -- bob registers notification token - DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ + DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns -- 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 + void $ messageNotificationData alice apns ("", _, CONF confId _ "bob's connInfo") <- get alice liftIO $ threadDelay 500000 allowConnection alice bobId confId "alice's connInfo" - void $ messageNotificationData bob apnsQ + void $ messageNotificationData bob apns get bob ##> ("", aliceId, INFO "alice's connInfo") - when (baseId == 3) $ void $ messageNotificationData alice apnsQ + when (baseId == 3) $ void $ messageNotificationData alice apns get alice ##> ("", bobId, CON) - when (baseId == 3) $ void $ messageNotificationData bob apnsQ + when (baseId == 3) $ void $ messageNotificationData bob apns 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 + void $ messageNotificationData alice apns 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 + void $ messageNotificationData bob apns get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False ackMessage bob aliceId (baseId + 2) Nothing -- no unexpected notifications should follow - noNotification apnsQ + noNotifications apns where msgId = subtract baseId -registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken -registerTestToken a token mode apnsQ = do +registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken +registerTestToken a token mode apns = 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 + Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- + timeout 1000000 $ getMockNotification apns tkn 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} = +testChangeNotificationsMode :: HasCallStack => APNSMockServer -> IO () +testChangeNotificationsMode apns = withAgentClients2 $ \alice bob -> runRight_ $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -603,12 +589,12 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, CON) -- register notification token, set mode to NMInstant - tkn <- registerTestToken alice "abcd" NMInstant apnsQ + tkn <- registerTestToken alice "abcd" NMInstant apns -- 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 + void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 1) Nothing -- set mode to NMPeriodic @@ -617,7 +603,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = liftIO $ threadDelay 750000 2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT $ baseId + 2) - noNotification apnsQ + noNotification alice apns get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 2) Nothing -- set mode to NMInstant @@ -626,7 +612,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = liftIO $ threadDelay 500000 3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there" get bob ##> ("", aliceId, SENT $ baseId + 3) - void $ messageNotificationData alice apnsQ + void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 3) Nothing -- turn off notifications @@ -635,26 +621,26 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = liftIO $ threadDelay 500000 4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there" get bob ##> ("", aliceId, SENT $ baseId + 4) - noNotification apnsQ + noNotifications apns 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 + void $ registerTestToken alice "abcd" NMInstant apns -- 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 + void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 5) Nothing -- no notifications should follow - noNotification apnsQ + noNotification alice apns where baseId = 1 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () -testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do +testChangeToken apns = 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 @@ -666,12 +652,12 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, CON) -- register notification token, set mode to NMInstant - void $ registerTestToken alice "abcd" NMInstant apnsQ + void $ registerTestToken alice "abcd" NMInstant apns -- 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 + void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 1) Nothing pure (aliceId, bobId) @@ -679,53 +665,66 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do subscribeConnection alice1 bobId -- change notification token - void $ registerTestToken alice1 "bcde" NMInstant apnsQ + void $ registerTestToken alice1 "bcde" NMInstant apns -- 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 + void $ messageNotificationData alice1 apns get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False ackMessage alice1 bobId (baseId + 2) Nothing -- no notifications should follow - noNotification apnsQ + noNotification alice1 apns 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) +testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do + withSmpServerStoreMsgLogOn t testPort $ \_ -> do + (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do + (aliceId, bobId) <- makeConnection alice bob + _ <- registerTestToken alice "abcd" NMInstant apns + liftIO $ threadDelay 250000 + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) + void $ messageNotificationData alice apns + 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 + + 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 apns + get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False + ackMessage alice bobId 3 Nothing + liftIO $ killThread threadId + + runRight_ $ do + 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "message 4" + get bob ##> ("", aliceId, SENT 4) + get alice =##> \case ("", c, Msg "message 4") -> c == bobId; _ -> False + ackMessage alice bobId 4 Nothing + noNotifications apns + + withSmpServerStoreMsgLogOn t testPort $ \_ -> + withNtfServerStoreLog t $ \_ -> runRight_ $ do + void $ messageNotificationData alice apns testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do +testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob - _ <- registerTestToken alice "abcd" NMInstant apnsQ + _ <- registerTestToken alice "abcd" NMInstant apns liftIO $ threadDelay 250000 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" get bob ##> ("", aliceId, SENT 2) - void $ messageNotificationData alice apnsQ + void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId 2 Nothing liftIO $ killThread threadId @@ -741,22 +740,22 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic liftIO $ threadDelay 1000000 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT 3) - _ <- messageNotificationData alice apnsQ + _ <- messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = +testNotificationsSMPRestartBatch n t apns = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do threadDelay 1000000 conns <- runServers $ do conns <- replicateM (n :: Int) $ makeConnection a b - _ <- registerTestToken a "abcd" NMInstant apnsQ + _ <- registerTestToken a "abcd" NMInstant apns 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 + void $ messageNotificationData a apns get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage a bobId msgId Nothing pure conns @@ -780,7 +779,7 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = forM_ conns $ \(aliceId, bobId) -> do msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again" get b ##> ("", aliceId, SENT msgId) - _ <- messageNotificationData a apnsQ + _ <- messageNotificationData a apns get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False where runServers :: ExceptT AgentErrorType IO a -> IO a @@ -792,16 +791,16 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = pure res testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () -testSwitchNotifications servers APNSMockServer {apnsQ} = +testSwitchNotifications servers apns = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId - _ <- registerTestToken a "abcd" NMInstant apnsQ + _ <- registerTestToken a "abcd" NMInstant apns liftIO $ threadDelay 250000 let testMessage msg = do msgId <- sendMessage b aId (SMP.MsgFlags True) msg get b ##> ("", aId, SENT msgId) - void $ messageNotificationData a apnsQ + void $ messageNotificationData a apns get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False ackMessage a bId msgId Nothing testMessage "hello" @@ -811,74 +810,80 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = testMessage "hello again" testNotificationsOldToken :: APNSMockServer -> IO () -testNotificationsOldToken APNSMockServer {apnsQ} = +testNotificationsOldToken apns = withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b - let testMessageAB = testMessage_ apnsQ a abId b baId - _ <- registerTestToken a "abcd" NMInstant apnsQ + let testMessageAB = testMessage_ apns a abId b baId + _ <- registerTestToken a "abcd" NMInstant apns 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 + _ <- registerTestToken a "xyzw" NMInstant apns 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 + let testMessageAC = testMessage_ apns a acId c caId testMessageAC "greetings" testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO () -testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = +testNotificationsNewToken apns 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 + let testMessageAB = testMessage_ apns a abId b baId + tkn <- registerTestToken a "abcd" NMInstant apns 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 + _ <- registerTestToken a "abcd" NMInstant apns 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 + let testMessageAC = testMessage_ apns 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 +testMessage_ :: HasCallStack => APNSMockServer -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO () +testMessage_ apns a aId b bId msg = do msgId <- sendMessage b aId (SMP.MsgFlags True) msg get b ##> ("", aId, SENT msgId) - void $ messageNotificationData a apnsQ + void $ messageNotificationData a apns 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 +messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString) +messageNotification apns tkn = do + 500000 `timeout` getMockNotification apns tkn >>= \case Nothing -> error "no notification" - Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do + Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> 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 +messageNotificationData :: HasCallStack => AgentClient -> APNSMockServer -> ExceptT AgentErrorType IO PNMessageData +messageNotificationData c apns = do + NtfToken {deviceToken, ntfDhSecret = Just dhSecret} <- getNtfTokenData c + (nonce, message) <- messageNotification apns deviceToken Right pnMsgs <- liftEither . first INTERNAL $ Right . parseAll pnMessagesP =<< first show (C.cbDecrypt dhSecret nonce message) pure $ L.last pnMsgs -noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO () -noNotification apnsQ = do - 500000 `timeout` atomically (readTBQueue apnsQ) >>= \case +noNotification :: AgentClient -> APNSMockServer -> ExceptT AgentErrorType IO () +noNotification c 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 + 500000 `timeout` getAnyMockNotification apns >>= \case Nothing -> pure () _ -> error "unexpected notification" diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index a12cbf1ea..e2427b565 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -14,11 +15,13 @@ import Crypto.Random (ChaChaDRG) import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) import qualified Data.List.NonEmpty as L +import Data.Time.Clock.System (SystemTime, getSystemTime) import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS import qualified Data.X509.File as XF import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Transport import Test.Hspec @@ -26,29 +29,30 @@ import Test.Hspec batchingTests :: Spec batchingTests = do describe "batchTransmissions" $ do - describe "SMP v6 (current)" $ do - it "should batch with 107 subscriptions per batch" testBatchSubscriptions + describe "SMP v6 (previous)" $ do + it "should batch with 107 subscriptions per batch" testBatchSubscriptionsV6 + it "should break on message that does not fit" testBatchWithMessageV6 + it "should break on large message" testBatchWithLargeMessageV6 + describe "SMP current" $ do + it "should batch with 136 subscriptions per batch" testBatchSubscriptions it "should break on message that does not fit" testBatchWithMessage it "should break on large message" testBatchWithLargeMessage - describe "v7 (next)" $ do - it "should batch with 136 subscriptions per batch" testBatchSubscriptionsV7 - it "should break on message that does not fit" testBatchWithMessageV7 - it "should break on large message" testBatchWithLargeMessageV7 describe "batchTransmissions'" $ do - describe "SMP v6 (current)" $ do - it "should batch with 107 subscriptions per batch" testClientBatchSubscriptions + describe "SMP v6 (previous)" $ do + it "should batch with 107 subscriptions per batch" testClientBatchSubscriptionsV6 + it "should break on message that does not fit" testClientBatchWithMessageV6 + it "should break on large message" testClientBatchWithLargeMessageV6 + describe "SMP current" $ do + it "should batch with 136 subscriptions per batch" testClientBatchSubscriptions + it "should batch with 255 ENDs per batch" testClientBatchENDs + it "should batch with 80 NMSGs per batch" testClientBatchNMSGs it "should break on message that does not fit" testClientBatchWithMessage it "should break on large message" testClientBatchWithLargeMessage - describe "v7 (next)" $ do - it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7 - it "should batch with N ENDs per batch" testClientBatchENDs - it "should break on message that does not fit" testClientBatchWithMessageV7 - it "should break on large message" testClientBatchWithLargeMessageV7 -testBatchSubscriptions :: IO () -testBatchSubscriptions = do +testBatchSubscriptionsV6 :: IO () +testBatchSubscriptionsV6 = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs <- replicateM 250 $ randomSUB sessId + subs <- replicateM 250 $ randomSUBv6 sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True length batches1 `shouldBe` 250 @@ -58,10 +62,10 @@ testBatchSubscriptions = do (n1, n2, n3) `shouldBe` (36, 107, 107) all lenOk [s1, s2, s3] `shouldBe` True -testBatchSubscriptionsV7 :: IO () -testBatchSubscriptionsV7 = do +testBatchSubscriptions :: IO () +testBatchSubscriptions = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs <- replicateM 300 $ randomSUBv7 sessId + subs <- replicateM 300 $ randomSUB sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True length batches1 `shouldBe` 300 @@ -71,6 +75,22 @@ testBatchSubscriptionsV7 = do (n1, n2, n3) `shouldBe` (28, 136, 136) all lenOk [s1, s2, s3] `shouldBe` True +testBatchWithMessageV6 :: IO () +testBatchWithMessageV6 = do + sessId <- atomically . C.randomBytes 32 =<< C.newRandom + subs1 <- replicateM 60 $ randomSUBv6 sessId + send <- randomSENDv6 sessId 8000 + subs2 <- replicateM 40 $ randomSUBv6 sessId + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` True + length batches1 `shouldBe` 101 + let batches = batchTransmissions True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 2 + [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches + (n1, n2) `shouldBe` (47, 54) + all lenOk [s1, s2] `shouldBe` True + testBatchWithMessage :: IO () testBatchWithMessage = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom @@ -84,31 +104,15 @@ testBatchWithMessage = do let batches = batchTransmissions True smpBlockSize $ L.fromList cmds length batches `shouldBe` 2 [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches - (n1, n2) `shouldBe` (47, 54) - all lenOk [s1, s2] `shouldBe` True - -testBatchWithMessageV7 :: IO () -testBatchWithMessageV7 = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs1 <- replicateM 60 $ randomSUBv7 sessId - send <- randomSENDv7 sessId 8000 - subs2 <- replicateM 40 $ randomSUBv7 sessId - let cmds = subs1 <> [send] <> subs2 - batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds - all lenOk1 batches1 `shouldBe` True - length batches1 `shouldBe` 101 - let batches = batchTransmissions True smpBlockSize $ L.fromList cmds - length batches `shouldBe` 2 - [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches (n1, n2) `shouldBe` (32, 69) all lenOk [s1, s2] `shouldBe` True -testBatchWithLargeMessage :: IO () -testBatchWithLargeMessage = do +testBatchWithLargeMessageV6 :: IO () +testBatchWithLargeMessageV6 = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs1 <- replicateM 50 $ randomSUB sessId - send <- randomSEND sessId 17000 - subs2 <- replicateM 150 $ randomSUB sessId + subs1 <- replicateM 50 $ randomSUBv6 sessId + send <- randomSENDv6 sessId 17000 + subs2 <- replicateM 150 $ randomSUBv6 sessId let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False @@ -122,12 +126,12 @@ testBatchWithLargeMessage = do (n1, n2, n3) `shouldBe` (50, 43, 107) all lenOk [s1, s2, s3] `shouldBe` True -testBatchWithLargeMessageV7 :: IO () -testBatchWithLargeMessageV7 = do +testBatchWithLargeMessage :: IO () +testBatchWithLargeMessage = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs1 <- replicateM 60 $ randomSUBv7 sessId - send <- randomSENDv7 sessId 17000 - subs2 <- replicateM 150 $ randomSUBv7 sessId + subs1 <- replicateM 60 $ randomSUB sessId + send <- randomSEND sessId 17000 + subs2 <- replicateM 150 $ randomSUB sessId let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False @@ -141,10 +145,10 @@ testBatchWithLargeMessageV7 = do (n1, n2, n3) `shouldBe` (60, 14, 136) all lenOk [s1, s2, s3] `shouldBe` True -testClientBatchSubscriptions :: IO () -testClientBatchSubscriptions = do - client <- testClientStub - subs <- replicateM 250 $ randomSUBCmd client +testClientBatchSubscriptionsV6 :: IO () +testClientBatchSubscriptionsV6 = do + client <- testClientStubV6 + subs <- replicateM 250 $ randomSUBCmdV6 client let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True let batches = batchTransmissions' True smpBlockSize $ L.fromList subs @@ -154,10 +158,10 @@ testClientBatchSubscriptions = do (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107) all lenOk [s1, s2, s3] `shouldBe` True -testClientBatchSubscriptionsV7 :: IO () -testClientBatchSubscriptionsV7 = do - client <- clientStubV7 - subs <- replicateM 300 $ randomSUBCmdV7 client +testClientBatchSubscriptions :: IO () +testClientBatchSubscriptions = do + client <- testClientStub + subs <- replicateM 300 $ randomSUBCmd client let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True let batches = batchTransmissions' True smpBlockSize $ L.fromList subs @@ -169,7 +173,7 @@ testClientBatchSubscriptionsV7 = do testClientBatchENDs :: IO () testClientBatchENDs = do - client <- clientStubV7 + client <- testClientStub ends <- replicateM 300 randomENDCmd let ends' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ends batches1 = batchTransmissions False smpBlockSize $ L.fromList ends' @@ -181,6 +185,38 @@ testClientBatchENDs = do (length rs1, length rs2) `shouldBe` (45, 255) all lenOk [s1, s2] `shouldBe` True +testClientBatchNMSGs :: IO () +testClientBatchNMSGs = do + client <- testClientStub + ts <- getSystemTime + ntfs <- replicateM 200 $ randomNMSGCmd ts + let ntfs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ntfs + batches1 = batchTransmissions False smpBlockSize $ L.fromList ntfs' + all lenOk1 batches1 `shouldBe` True + let batches = batchTransmissions True smpBlockSize $ L.fromList ntfs' + length batches `shouldBe` 3 + [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches + (n1, n2, n3) `shouldBe` (40, 80, 80) + (length rs1, length rs2, length rs3) `shouldBe` (40, 80, 80) + all lenOk [s1, s2, s3] `shouldBe` True + +testClientBatchWithMessageV6 :: IO () +testClientBatchWithMessageV6 = do + client <- testClientStubV6 + subs1 <- replicateM 60 $ randomSUBCmdV6 client + send <- randomSENDCmdV6 client 8000 + subs2 <- replicateM 40 $ randomSUBCmdV6 client + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` True + length batches1 `shouldBe` 101 + let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 2 + [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches + (n1, n2) `shouldBe` (47, 54) + (length rs1, length rs2) `shouldBe` (47, 54) + all lenOk [s1, s2] `shouldBe` True + testClientBatchWithMessage :: IO () testClientBatchWithMessage = do client <- testClientStub @@ -194,33 +230,16 @@ testClientBatchWithMessage = do let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds length batches `shouldBe` 2 [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches - (n1, n2) `shouldBe` (47, 54) - (length rs1, length rs2) `shouldBe` (47, 54) - all lenOk [s1, s2] `shouldBe` True - -testClientBatchWithMessageV7 :: IO () -testClientBatchWithMessageV7 = do - client <- clientStubV7 - subs1 <- replicateM 60 $ randomSUBCmdV7 client - send <- randomSENDCmdV7 client 8000 - subs2 <- replicateM 40 $ randomSUBCmdV7 client - let cmds = subs1 <> [send] <> subs2 - batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds - all lenOk1 batches1 `shouldBe` True - length batches1 `shouldBe` 101 - let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds - length batches `shouldBe` 2 - [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches (n1, n2) `shouldBe` (32, 69) (length rs1, length rs2) `shouldBe` (32, 69) all lenOk [s1, s2] `shouldBe` True -testClientBatchWithLargeMessage :: IO () -testClientBatchWithLargeMessage = do - client <- testClientStub - subs1 <- replicateM 50 $ randomSUBCmd client - send <- randomSENDCmd client 17000 - subs2 <- replicateM 150 $ randomSUBCmd client +testClientBatchWithLargeMessageV6 :: IO () +testClientBatchWithLargeMessageV6 = do + client <- testClientStubV6 + subs1 <- replicateM 50 $ randomSUBCmdV6 client + send <- randomSENDCmdV6 client 17000 + subs2 <- replicateM 150 $ randomSUBCmdV6 client let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False @@ -244,12 +263,12 @@ testClientBatchWithLargeMessage = do (length rs1', length rs2') `shouldBe` (93, 107) all lenOk [s1', s2'] `shouldBe` True -testClientBatchWithLargeMessageV7 :: IO () -testClientBatchWithLargeMessageV7 = do - client <- clientStubV7 - subs1 <- replicateM 60 $ randomSUBCmdV7 client - send <- randomSENDCmdV7 client 17000 - subs2 <- replicateM 150 $ randomSUBCmdV7 client +testClientBatchWithLargeMessage :: IO () +testClientBatchWithLargeMessage = do + client <- testClientStub + subs1 <- replicateM 60 $ randomSUBCmd client + send <- randomSENDCmd client 17000 + subs2 <- replicateM 150 $ randomSUBCmd client let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False @@ -273,25 +292,25 @@ testClientBatchWithLargeMessageV7 = do (length rs1', length rs2') `shouldBe` (74, 136) all lenOk [s1', s2'] `shouldBe` True -testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) -testClientStub = do +testClientStubV6 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) +testClientStubV6 = do g <- C.newRandom sessId <- atomically $ C.randomBytes 32 g smpClientStub g sessId subModeSMPVersion Nothing -clientStubV7 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) -clientStubV7 = do +testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) +testClientStub = do g <- C.newRandom sessId <- atomically $ C.randomBytes 32 g (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g - thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey - smpClientStub g sessId authCmdsSMPVersion thAuth_ + thAuth_ <- testTHandleAuth currentClientSMPRelayVersion g rKey + smpClientStub g sessId currentClientSMPRelayVersion thAuth_ + +randomSUBv6 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSUBv6 = randomSUB_ C.SEd25519 subModeSMPVersion randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSUB = randomSUB_ C.SEd25519 subModeSMPVersion - -randomSUBv7 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSUBv7 = randomSUB_ C.SEd25519 authCmdsSMPVersion +randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSUB_ a v sessId = do @@ -304,11 +323,11 @@ randomSUB_ a v sessId = do TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB) pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth -randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) -randomSUBCmd = randomSUBCmd_ C.SEd25519 +randomSUBCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) +randomSUBCmdV6 = randomSUBCmd_ C.SEd25519 -randomSUBCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) -randomSUBCmdV7 = randomSUBCmd_ C.SEd25519 -- same as v6 +randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) +randomSUBCmd = randomSUBCmd_ C.SEd25519 -- same as v6 randomSUBCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd_ a c = do @@ -323,11 +342,22 @@ randomENDCmd = do rId <- atomically $ C.randomBytes 24 g pure (CorrId "", EntityId rId, END) -randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion +randomNMSGCmd :: SystemTime -> IO (Transmission BrokerMsg) +randomNMSGCmd ts = do + g <- C.newRandom + nId <- atomically $ C.randomBytes 24 g + msgId <- atomically $ C.randomBytes 24 g + (k, pk) <- atomically $ C.generateKeyPair g + nonce <- atomically $ C.randomCbNonce g + let msgMeta = NMsgMeta {msgId, msgTs = ts} + Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128 + pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta) -randomSENDv7 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSENDv7 = randomSEND_ C.SX25519 authCmdsSMPVersion +randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSENDv6 = randomSEND_ C.SEd25519 subModeSMPVersion + +randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSEND = randomSEND_ C.SX25519 currentClientSMPRelayVersion randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSEND_ a v sessId len = do @@ -365,11 +395,11 @@ testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing} _ -> pure Nothing -randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) -randomSENDCmd = randomSENDCmd_ C.SEd25519 +randomSENDCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) +randomSENDCmdV6 = randomSENDCmd_ C.SEd25519 -randomSENDCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) -randomSENDCmdV7 = randomSENDCmd_ C.SX25519 +randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) +randomSENDCmd = randomSENDCmd_ C.SX25519 randomSENDCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) randomSENDCmd_ a c len = do diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 87ff797f0..6c38af721 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -14,14 +15,18 @@ module NtfClient where +import Control.Concurrent.STM (retry) import Control.Monad import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class import Data.Aeson (FromJSON (..), ToJSON (..), (.:)) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map.Strict as M import Data.Text (Text) import GHC.Generics (Generic) import Network.HTTP.Types (Status) @@ -33,13 +38,14 @@ 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 (NtfResponse) +import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) @@ -83,9 +89,9 @@ ntfServerCfg = { transports = [], subIdBytes = 24, regCodeBytes = 32, - clientQSize = 1, - subQSize = 1, - pushQSize = 1, + clientQSize = 2, + subQSize = 2, + pushQSize = 2, smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0}, apnsConfig = defaultAPNSPushClientConfig @@ -124,7 +130,7 @@ ntfServerCfgVPrev = withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t, False)]} -withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a +withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]} withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a @@ -136,10 +142,10 @@ withNtfServerCfg cfg@NtfServerConfig {transports} = (\started -> runNtfServerBlocking started cfg) (pure ()) -withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a +withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => IO a) -> IO a withNtfServerOn t port' = withNtfServerThreadOn t port' . const -withNtfServer :: ATransport -> IO a -> IO a +withNtfServer :: HasCallStack => ATransport -> (HasCallStack => IO a) -> IO a withNtfServer t = withNtfServerOn t ntfTestPort runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a @@ -166,22 +172,21 @@ ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expect ntfTest _ test' = runNtfTest test' `shouldReturn` () data APNSMockRequest = APNSMockRequest - { notification :: APNSNotification, - sendApnsResponse :: APNSMockResponse -> IO () + { notification :: APNSNotification } data APNSMockResponse = APNSRespOk | APNSRespError Status Text data APNSMockServer = APNSMockServer { action :: Async (), - apnsQ :: TBQueue APNSMockRequest, + notifications :: TM.TMap ByteString (TBQueue APNSMockRequest), http2Server :: HTTP2Server } apnsMockServerConfig :: HTTP2ServerConfig apnsMockServerConfig = HTTP2ServerConfig - { qSize = 1, + { qSize = 2, http2Port = apnsTestPort, bufferSize = 16384, bodyHeadSize = 16384, @@ -224,23 +229,36 @@ deriving instance ToJSON APNSErrorResponse getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer getAPNSMockServer config@HTTP2ServerConfig {qSize} = do http2Server <- getHTTP2Server config Nothing - apnsQ <- newTBQueueIO qSize - action <- async $ runAPNSMockServer apnsQ http2Server - pure APNSMockServer {action, apnsQ, http2Server} + notifications <- TM.emptyIO + action <- async $ runAPNSMockServer notifications http2Server + pure APNSMockServer {action, notifications, http2Server} where - runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do - HTTP2Request {reqBody = HTTP2Body {bodyHead}, sendResponse} <- atomically $ readTBQueue reqQ + 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 -> sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason} case J.decodeStrict' bodyHead of - Just notification -> - atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse} + 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 + 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" +getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest +getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do + atomically $ TM.lookup token notifications >>= maybe retry readTBQueue + +getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest +getAnyMockNotification APNSMockServer {notifications} = do + atomically $ readTVar notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf + closeAPNSMockServer :: APNSMockServer -> IO () closeAPNSMockServer APNSMockServer {action, http2Server} = do closeHTTP2Server http2Server diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index e3349e9a3..b9560976d 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -104,16 +104,15 @@ testNotificationSubscription (ATransport t) = (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" - withAPNSMockServer $ \APNSMockServer {apnsQ} -> + withAPNSMockServer $ \apns -> smpTest2 t $ \rh sh -> ntfTest t $ \nh -> do -- create queue (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub -- 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}, sendApnsResponse = send} <- - atomically $ readTBQueue apnsQ - send APNSRespOk + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn let dhSecret = C.dh' ntfDh dhPriv Right verification = ntfData .-> "verification" Right nonce = C.cbNonce <$> ntfData .-> "nonce" @@ -131,7 +130,7 @@ testNotificationSubscription (ATransport t) = threadDelay 50000 Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello") -- receive notification - APNSMockRequest {notification, sendApnsResponse = send'} <- atomically $ readTBQueue apnsQ + APNSMockRequest {notification} <- getMockNotification apns tkn let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification Right nonce' = C.cbNonce <$> ntfData' .-> "nonce" Right message = ntfData' .-> "message" @@ -142,7 +141,6 @@ testNotificationSubscription (ATransport t) = Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta smpServer `shouldBe` srv notifierId `shouldBe` nId - send' APNSRespOk -- receive message Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body) @@ -154,9 +152,8 @@ testNotificationSubscription (ATransport t) = let tkn' = DeviceToken PPApnsTest "efgh" RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn') tId `shouldBe` tId' - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}, sendApnsResponse = send2} <- - atomically $ readTBQueue apnsQ - send2 APNSRespOk + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <- + getMockNotification apns tkn' let Right verification2 = ntfData2 .-> "verification" Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce" Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2 @@ -164,7 +161,7 @@ testNotificationSubscription (ATransport t) = 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, sendApnsResponse = send3} <- atomically $ readTBQueue apnsQ + APNSMockRequest {notification = notification3} <- getMockNotification apns tkn' let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3 Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce" Right message3 = ntfData3 .-> "message" @@ -173,4 +170,3 @@ testNotificationSubscription (ATransport t) = APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2 smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId - send3 APNSRespOk diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 970be7174..273cc90ad 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -62,6 +62,12 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log" testStoreMsgsFile2 :: FilePath testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2" +testStoreNtfsFile :: FilePath +testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log" + +testStoreNtfsFile2 :: FilePath +testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2" + testServerStatsBackupFile :: FilePath testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" @@ -104,17 +110,20 @@ cfg = msgIdBytes = 24, storeLogFile = Nothing, storeMsgsFile = Nothing, + storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, controlPortUserAuth = Nothing, controlPortAdminAuth = Nothing, messageExpiration = Just defaultMessageExpiration, + notificationExpiration = defaultNtfExpiration, inactiveClientExpiration = Just defaultInactiveClientExpiration, logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/smp-server-stats.daily.log", serverStatsBackupFile = Nothing, pendingENDInterval = 500000, + ntfDeliveryInterval = 200000, smpCredentials = ServerCredentials { caCertificateFile = Just "tests/fixtures/ca.crt", @@ -159,7 +168,15 @@ proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} +withSmpServerStoreMsgLogOn t = + withSmpServerConfigOn + t + cfg + { storeLogFile = Just testStoreLogFile, + storeMsgsFile = Just testStoreMsgsFile, + storeNtfsFile = Just testStoreNtfsFile, + serverStatsBackupFile = Just testServerStatsBackupFile + } withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile} diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 6fe10b38b..2025ff911 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -375,11 +375,11 @@ agentViaProxyRetryOffline = do ackMessage alice bobId (baseId + 4) Nothing where withServer :: (ThreadId -> IO a) -> IO a - withServer = withServer_ testStoreLogFile testStoreMsgsFile testPort + withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort withServer2 :: (ThreadId -> IO a) -> IO a - withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testPort2 - withServer_ storeLog storeMsgs port = - withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port + withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2 + withServer_ storeLog storeMsgs storeNtfs port = + withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} port a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 0a1729ab8..d1ba7c67f 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -615,7 +615,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 2 logSize testStoreMsgsFile `shouldReturn` 5 - logSize testServerStatsBackupFile `shouldReturn` 72 + logSize testServerStatsBackupFile `shouldReturn` 74 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 @@ -633,7 +633,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd logSize testStoreMsgsFile `shouldReturn` 3 - logSize testServerStatsBackupFile `shouldReturn` 72 + logSize testServerStatsBackupFile `shouldReturn` 74 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -652,7 +652,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 logSize testStoreMsgsFile `shouldReturn` 0 - logSize testServerStatsBackupFile `shouldReturn` 72 + logSize testServerStatsBackupFile `shouldReturn` 74 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5