diff --git a/src/Simplex/Chat/Web.hs b/src/Simplex/Chat/Web.hs index 895ab51562..e4f9e12fc5 100644 --- a/src/Simplex/Chat/Web.hs +++ b/src/Simplex/Chat/Web.hs @@ -23,7 +23,7 @@ module Simplex.Chat.Web ) where -import Control.Concurrent.STM (check) +import Control.Concurrent.STM (check, flushTQueue) import Control.Exception (SomeException, catch) import Control.Logger.Simple import Control.Monad (forM_, void, when) @@ -145,9 +145,9 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva drainRemovals drainPriority handleCors - drainRoutine - timerFired <- interruptibleSleep - when timerFired $ seedRoutinePending wps + renderRoutine + noRoutine <- atomically $ S.null <$> readTVar routinePending + when noRoutine waitRefresh workerLoop wps where drainRemovals = atomically (tryReadTQueue filesToRemove) >>= \case @@ -156,34 +156,32 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva removeFile (webJsonDir f) `catch` \(_ :: SomeException) -> pure () drainRemovals - drainPriority = atomically (tryReadTQueue priorityRender) >>= \case - Nothing -> pure () - Just gId -> do - renderOneGroup wps gId - drainPriority + -- flush the whole queue and render each group once: a burst of changes in one + -- channel enqueues its id many times, but only needs a single render + drainPriority = do + gIds <- atomically $ flushTQueue priorityRender + forM_ (S.fromList gIds) $ renderOneGroup wps handleCors = do needed <- atomically $ swapTVar corsNeeded False when needed $ regenerateCors wps - drainRoutine = do + -- render a single routine item; the main loop calls this once per iteration + renderRoutine = do mGId <- atomically $ do pending <- readTVar routinePending case S.minView pending of Nothing -> pure Nothing Just (gId, rest) -> writeTVar routinePending rest >> pure (Just gId) - forM_ mGId $ \gId -> do - renderOneGroup wps gId - drainPriority - drainRoutine + forM_ mGId $ renderOneGroup wps - -- returns True when the refresh timer fired, False when woken early by a change signal; - -- a full routine re-render is only seeded on the timer, so changes render incrementally - interruptibleSleep = do + -- routine list drained: wait for the refresh timer or a change signal; only the timer + -- seeds the next full sweep, a change just returns to let the main loop service it + waitRefresh = do delay <- registerDelay (webUpdateInterval * 1000000) - atomically $ - (True <$ (readTVar delay >>= check)) - `orElse` (False <$ takeTMVar wakeSignal) + timerFired <- atomically $ + (True <$ (readTVar delay >>= check)) `orElse` (False <$ takeTMVar wakeSignal) + when timerFired $ seedRoutinePending wps initPublishableGroups WebPreviewState {publishableGroupIds} = do rows <- withTransaction (chatStore cc) $ \db ->