smp-server: fix notification store key retention leak

deleteExpiredNtfs trimmed each notifier's message list but never removed
the outer NtfStore map key, so one empty entry per notifier queue that
ever received a notification was retained forever (grows with the active
notifier set, never shrinks).

Remove the outer key when its list becomes empty, and make storeNtf fully
atomic so it cannot race the removal and write a notification to an
orphaned TVar. Verified with the load bench (ntfexp): after expiry
ntfStore_keys drops from the queue count to 0 instead of staying flat.
This commit is contained in:
sh
2026-07-06 12:33:48 +00:00
parent 732f86bb01
commit 3cc449ba98
+12 -16
View File
@@ -33,13 +33,10 @@ data MsgNtf = MsgNtf
}
storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO ()
storeNtf (NtfStore ns) nId ntf = do
TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :))
storeNtf (NtfStore ns) nId ntf =
-- TODO [ntfdb] 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 :))
atomically $ TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :))
deleteNtfs :: NtfStore -> NotifierId -> IO Int
deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO)
@@ -48,18 +45,17 @@ 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
expireQueue nId = atomically $ TM.lookup nId ns >>= maybe (pure 0) (expire nId)
expire nId v = readTVar v >>= \case
[] -> TM.delete nId ns >> 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
if null ntfs'
then TM.delete nId ns >> pure (length ntfs)
else writeTVar v ntfs' >> pure (length ntfs - length ntfs')
| otherwise -> pure 0
data NtfLogRecord = NLRv1 NotifierId MsgNtf