diff --git a/auto-update/ChangeLog.md b/auto-update/ChangeLog.md index 6dcb12845..4f9be3736 100644 --- a/auto-update/ChangeLog.md +++ b/auto-update/ChangeLog.md @@ -1,5 +1,15 @@ # ChangeLog for auto-update +## 0.2.2 + +* [#996](https://github.com/yesodweb/wai/pull/996): + Refactored the `Control.Debounce` logic to not leak threads. +* [#996](https://github.com/yesodweb/wai/pull/996): + Added extra `DebounceEdge` options for different types of debouncing. + * `LeadingMute`: Action on first trigger, and ignore any triggers during cooldown + * `TrailingDelay`: First trigger starts cooldown, and + triggers during cooldown extend the cooldown. Action when cooldown expires. + ## 0.2.1 * Labeling threads. @@ -8,19 +18,19 @@ * Creating Reaper.Internal to export Reaper constructor. * Hiding Reaper constructor. -* Add `reaperModify` to the `Reaper` API, allowing workload modification outside +* [#985](https://github.com/yesodweb/wai/pull/985): + Add `reaperModify` to the `Reaper` API, allowing workload modification outside of the main `reaperAction` loop. - [#985](https://github.com/yesodweb/wai/pull/985) ## 0.1.6 -* Add control of activation on leading vs. trailing edges for Control.Debounce - [#756](https://github.com/yesodweb/wai/pull/756) +* [#756](https://github.com/yesodweb/wai/pull/756): + Add control of activation on leading vs. trailing edges for Control.Debounce ## 0.1.5 -* Using the Strict and StrictData language extensions for GHC >8. - [#752](https://github.com/yesodweb/wai/pull/752) +* [#752](https://github.com/yesodweb/wai/pull/752): + Using the Strict and StrictData language extensions for GHC >8. ## 0.1.4.1 diff --git a/auto-update/Control/Debounce.hs b/auto-update/Control/Debounce.hs index 33b123574..aecd85143 100644 --- a/auto-update/Control/Debounce.hs +++ b/auto-update/Control/Debounce.hs @@ -23,22 +23,26 @@ -- -- @since 0.1.2 module Control.Debounce ( - -- * Type + -- * Creation + mkDebounce, + + -- * Settings DI.DebounceSettings, defaultDebounceSettings, - -- * Accessors + -- ** Accessors DI.debounceFreq, DI.debounceAction, DI.debounceEdge, + + -- ** Edge types DI.leadingEdge, + DI.leadingMuteEdge, DI.trailingEdge, - - -- * Creation - mkDebounce, + DI.trailingDelayEdge, ) where -import Control.Concurrent (newEmptyMVar, threadDelay) +import Control.Concurrent (newMVar, threadDelay) import qualified Control.Debounce.Internal as DI -- | Default value for creating a 'DebounceSettings'. @@ -54,8 +58,11 @@ defaultDebounceSettings = -- | Generate an action which will trigger the debounced action to be performed. -- +-- /N.B. The generated action will always immediately return, regardless of the 'debounceFreq',/ +-- /as the debounced action (and the delay\/cooldown) is always performed in a separate thread./ +-- -- @since 0.1.2 mkDebounce :: DI.DebounceSettings -> IO (IO ()) mkDebounce settings = do - baton <- newEmptyMVar + baton <- newMVar () DI.mkDebounceInternal baton threadDelay settings diff --git a/auto-update/Control/Debounce/Internal.hs b/auto-update/Control/Debounce/Internal.hs index a502efe24..9b89a5db9 100644 --- a/auto-update/Control/Debounce/Internal.hs +++ b/auto-update/Control/Debounce/Internal.hs @@ -5,19 +5,24 @@ module Control.Debounce.Internal ( DebounceSettings (..), DebounceEdge (..), leadingEdge, + leadingMuteEdge, trailingEdge, + trailingDelayEdge, mkDebounceInternal, ) where import Control.Concurrent (forkIO) import Control.Concurrent.MVar ( MVar, - takeMVar, + newEmptyMVar, + putMVar, tryPutMVar, tryTakeMVar, ) import Control.Exception (SomeException, handle, mask_) -import Control.Monad (forever, void) +import Control.Monad (void, when) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Conc (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) import GHC.Conc.Sync (labelThread) -- | Settings to control how debouncing should work. @@ -49,7 +54,7 @@ data DebounceSettings = DebounceSettings -- ^ Whether to perform the action on the leading edge or trailing edge of -- the timeout. -- - -- Default: 'trailingEdge'. + -- Default: 'leadingEdge'. -- -- @since 0.1.6 } @@ -63,42 +68,229 @@ data DebounceEdge -- If the trigger happens again during the cooldown, wait until the end of the cooldown -- and then perform the action again, then enter a new cooldown period. Leading + | -- | Perform the action immediately, and then begin a cooldown period. + -- If the trigger happens again during the cooldown, it is ignored. + LeadingMute | -- | Start a cooldown period and perform the action when the period ends. If another trigger -- happens during the cooldown, it has no effect. Trailing + | -- | Start a cooldown period and perform the action when the period ends. If another trigger + -- happens during the cooldown, it restarts the cooldown again. + TrailingDelay deriving (Show, Eq) -- | Perform the action immediately, and then begin a cooldown period. -- If the trigger happens again during the cooldown, wait until the end of the cooldown -- and then perform the action again, then enter a new cooldown period. -- +-- Example of how this style debounce works: +-- +-- > ! = function execution +-- > . = cooldown period +-- > X = debounced code execution +-- > +-- > ! ! ! ! +-- > ....... ....... ....... ....... +-- > X X X X +-- -- @since 0.1.6 leadingEdge :: DebounceEdge leadingEdge = Leading --- | Start a cooldown period and perform the action when the period ends. If another trigger --- happens during the cooldown, it has no effect. +-- | Perform the action immediately, and then begin a cooldown period. +-- If the trigger happens again during the cooldown, it is ignored. +-- +-- Example of how this style debounce works: +-- +-- > ! = function execution +-- > . = cooldown period +-- > X = debounced code execution +-- > +-- > ! ! ! ! +-- > ....... ....... +-- > X X +-- +-- @since 0.1.6 +leadingMuteEdge :: DebounceEdge +leadingMuteEdge = LeadingMute + +-- | Start a cooldown period and perform the action when the period ends. +-- If another trigger happens during the cooldown, it has no effect. +-- +-- Example of how this style debounce works: +-- +-- @ +-- ! = function execution +-- . = cooldown period +-- X = debounced code execution +-- +-- ! ! ! ! +-- ....... ....... +-- X X +-- @ -- -- @since 0.1.6 trailingEdge :: DebounceEdge trailingEdge = Trailing +-- | Start a cooldown period and perform the action when the period ends. +-- If another trigger happens during the cooldown, it restarts the cooldown again. +-- +-- /N.B. If a trigger happens DURING the 'debounceAction' it starts a new cooldown./ +-- /So if the 'debounceAction' takes longer than the 'debounceFreq', it might run/ +-- /again before the previous action has ended./ +-- +-- Example of how this style debounce works: +-- +-- @ +-- ! = function execution +-- . = cooldown period +-- X = debounced code execution +-- +-- ! ! ! ! +-- ....... ............... +-- X X +-- @ +-- +-- @since 0.1.6 +trailingDelayEdge :: DebounceEdge +trailingDelayEdge = TrailingDelay + mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ()) -mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do - tid <- mask_ $ forkIO $ forever $ do - takeMVar baton - case edge of - Leading -> do +-- \* LEADING +-- +-- 1) try take baton to start +-- 2) succes -> empty trigger & start worker, failed -> fill trigger +-- 3) worker do action +-- 4) delay +-- 5) try take trigger +-- 6) success -> repeat action, failed -> put baton back +mkDebounceInternal baton delayFn (DebounceSettings freq action Leading) = do + trigger <- newEmptyMVar + pure $ do + -- 1) + success <- tryTakeMVar baton + case success of + -- 2) + Nothing -> void $ tryPutMVar trigger () + Just () -> do + void $ tryTakeMVar trigger + startWorker trigger + where + startWorker trigger = + let loop = do + -- 3) ignoreExc action + -- 4) delayFn freq - Trailing -> do - delayFn freq - -- Empty the baton of any other activations during the interval - void $ tryTakeMVar baton - ignoreExc action - labelThread tid "Denounce" - return $ void $ tryPutMVar baton () + -- 5) + isTriggered <- tryTakeMVar trigger + case isTriggered of + -- 6) + Nothing -> putMVar baton () + Just () -> loop + in forkAndLabel "Leading" loop +-- \* LEADING MUTE +-- +-- 1) try take baton to start +-- 2) success -> start worker, failed -> die +-- 3) worker delay +-- 4) do action +-- 5) put baton back +mkDebounceInternal baton delayFn (DebounceSettings freq action LeadingMute) = + pure $ do + -- 1) + success <- tryTakeMVar baton + case success of + -- 2) + Nothing -> pure () + Just () -> + forkAndLabel "LeadingMute" $ do + -- 3) + ignoreExc action + -- 4) + delayFn freq + -- 5) + putMVar baton () +-- \* TRAILING +-- +-- 1) try take baton to start +-- 2) success -> start worker, failed -> die +-- 3) worker delay +-- 4) do action +-- 5) put baton back +mkDebounceInternal baton delayFn (DebounceSettings freq action Trailing) = + pure $ do + -- 1) + success <- tryTakeMVar baton + case success of + -- 2) + Nothing -> pure () + Just () -> + forkAndLabel "Trailing" $ do + -- 3) + delayFn freq + -- 4) + ignoreExc action + -- 5) + putMVar baton () +-- \* TRAILING DELAY +-- +-- 1) get current time -> /now/ +-- 2) try take baton to start +-- 3) success -> set time var to /now/ & start worker, failed -> update time var to /now/ +-- 4) worker waits minimum delay +-- 5) check diff of time var with /now/ +-- 6) less -> wait the difference, same/more -> do action +-- 7) after action, recheck if there was any trigger +-- 8) put baton back +mkDebounceInternal baton delayFn (DebounceSettings freq action TrailingDelay) = do + -- 1) + timeTVar <- newTVarIO minBound + pure $ do + now <- getMonotonicTimeNSec + -- 2) + success <- tryTakeMVar baton + case success of + -- 3) + Nothing -> atomically $ do + oldTime <- readTVar timeTVar + when (oldTime < now) $ writeTVar timeTVar now + Just () -> do + atomically $ writeTVar timeTVar now + forkAndLabel "TrailingDelay" $ go timeTVar freq + where + go timeTVar = loop + where + loop delay = do + -- 4) + delayFn delay + lastTrigger <- readTVarIO timeTVar + now <- getMonotonicTimeNSec + -- 5) + let diff = fromIntegral (now - lastTrigger) `div` 1000 + shouldWait = diff < freq + if shouldWait + -- 6) + then loop $ freq - diff + else do + ignoreExc action + timeAfterAction <- readTVarIO timeTVar + -- 7) + let wasTriggered = timeAfterAction > now + if wasTriggered + then do + updatedNow <- getMonotonicTimeNSec + let newDiff = fromIntegral (updatedNow - timeAfterAction) `div` 1000 + loop $ freq - newDiff + -- 8) + else putMVar baton () + +forkAndLabel :: String -> IO () -> IO () +forkAndLabel s act = do + tid <- mask_ $ forkIO act + labelThread tid $ "Debounce (" <> s <> "): " <> show tid ignoreExc :: IO () -> IO () ignoreExc = handle $ \(_ :: SomeException) -> return () diff --git a/auto-update/auto-update.cabal b/auto-update/auto-update.cabal index b33ad6505..ccac45c1b 100644 --- a/auto-update/auto-update.cabal +++ b/auto-update/auto-update.cabal @@ -1,5 +1,5 @@ name: auto-update -version: 0.2.1 +version: 0.2.2 synopsis: Efficiently run periodic, on-demand actions description: API docs and the README are available at . homepage: https://github.com/yesodweb/wai diff --git a/auto-update/test/Control/DebounceSpec.hs b/auto-update/test/Control/DebounceSpec.hs index 0be944077..23fe76738 100644 --- a/auto-update/test/Control/DebounceSpec.hs +++ b/auto-update/test/Control/DebounceSpec.hs @@ -1,14 +1,30 @@ +{-# LANGUAGE NumericUnderscores #-} module Control.DebounceSpec (main, spec) where -import Control.Concurrent -import Control.Debounce +import Control.Concurrent ( + MVar, + newEmptyMVar, + takeMVar, + putMVar, + newMVar, + threadDelay, + tryReadMVar, + ) +import Control.Debounce ( + DebounceSettings(..), + leadingEdge, + leadingMuteEdge, + trailingEdge, + trailingDelayEdge, + defaultDebounceSettings, + ) import qualified Control.Debounce.Internal as DI -import Control.Monad +import Control.Monad (void) import Control.Monad.Catch -import Control.Retry -import Data.IORef -import Test.HUnit.Lang -import Test.Hspec +import Control.Retry (recovering, constantDelay, limitRetries) +import Data.IORef (IORef, readIORef, newIORef, modifyIORef) +import Test.Hspec (Spec, describe, it, shouldReturn, hspec) +import Test.HUnit.Lang (HUnitFailure (HUnitFailure)) spec :: Spec spec = describe "mkDebounce" $ do @@ -43,6 +59,39 @@ spec = describe "mkDebounce" $ do returnFromWait pause readIORef ref `shouldReturn` 2 + describe "LeadingMute edge" $ do + it "works for a single event" $ do + (ref, debounced, _baton, returnFromWait) <- getDebounce leadingMuteEdge + + debounced + waitUntil 5 $ readIORef ref `shouldReturn` 1 + + returnFromWait + pause + readIORef ref `shouldReturn` 1 + + -- Try another round + debounced + waitUntil 5 $ readIORef ref `shouldReturn` 2 + + returnFromWait + pause + readIORef ref `shouldReturn` 2 + + it "works for multiple events" $ do + (ref, debounced, baton, returnFromWait) <- getDebounce leadingMuteEdge + + debounced + waitForBatonToBeTaken baton + debounced + pause + debounced + waitUntil 5 $ readIORef ref `shouldReturn` 1 + debounced + + returnFromWait + pause + readIORef ref `shouldReturn` 1 describe "Trailing edge" $ do it "works for a single event" $ do @@ -50,7 +99,7 @@ spec = describe "mkDebounce" $ do debounced pause - waitUntil 5 $ readIORef ref `shouldReturn` 0 + readIORef ref `shouldReturn` 0 returnFromWait waitUntil 5 $ readIORef ref `shouldReturn` 1 @@ -70,11 +119,42 @@ spec = describe "mkDebounce" $ do waitForBatonToBeTaken baton debounced pause - waitUntil 5 $ readIORef ref `shouldReturn` 0 + readIORef ref `shouldReturn` 0 returnFromWait waitUntil 5 $ readIORef ref `shouldReturn` 1 + describe "TrailingDelay edge" $ do + it "works for a single event" $ do + (ref, debounced, _baton, _returnFromWait) <- getDebounce' True trailingDelayEdge + + debounced + readIORef ref `shouldReturn` 0 + + waitUntil 1 $ readIORef ref `shouldReturn` 1 + + -- Try another round + debounced + readIORef ref `shouldReturn` 1 + + waitUntil 1 $ readIORef ref `shouldReturn` 2 + + it "works for multiple events" $ do + (ref, debounced, _baton, _returnFromWait) <- getDebounce' True trailingDelayEdge + + debounced + readIORef ref `shouldReturn` 0 + threadDelay 500_000 + readIORef ref `shouldReturn` 0 + debounced + readIORef ref `shouldReturn` 0 + threadDelay 500_000 + readIORef ref `shouldReturn` 0 + threadDelay 250_000 + readIORef ref `shouldReturn` 0 + + waitUntil 1 $ readIORef ref `shouldReturn` 1 + -- | Make a controllable delay function getWaitAction :: IO (p -> IO (), IO ()) getWaitAction = do @@ -83,22 +163,28 @@ getWaitAction = do let returnFromWait = putMVar waitVar () return (waitAction, returnFromWait) --- | Get a debounce system with access to the internals for testing getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ()) -getDebounce edge = do +getDebounce = getDebounce' False + +-- | Get a debounce system with access to the internals for testing +getDebounce' :: Bool -> DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ()) +getDebounce' useThreadDelay edge = do ref <- newIORef 0 let action = modifyIORef ref (+ 1) - (waitAction, returnFromWait) <- getWaitAction + (waitAction, returnFromWait) <- + if useThreadDelay + then pure (threadDelay, pure ()) + else getWaitAction - baton <- newEmptyMVar + baton <- newMVar () debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings - { debounceFreq = 5000000 -- unused + { debounceFreq = 1_000_000 -- used in 'TrailingDelay' , debounceAction = action , debounceEdge = edge } @@ -107,14 +193,16 @@ getDebounce edge = do -- | Pause briefly (100ms) pause :: IO () -pause = threadDelay 100000 +pause = threadDelay 100_000 waitForBatonToBeTaken :: MVar () -> IO () -waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton `shouldReturn` Nothing +waitForBatonToBeTaken baton = + waitUntil 5 $ tryReadMVar baton `shouldReturn` Nothing -- | Wait up to n seconds for an action to complete without throwing an HUnitFailure waitUntil :: Int -> IO a -> IO () -waitUntil n action = recovering policy [handler] (\_status -> void action) +waitUntil n action = + recovering policy [handler] (\_status -> void action) where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds handler _status = Handler (\HUnitFailure{} -> return True) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 10a7f942d..5c433f923 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -23,9 +23,7 @@ nix: - fcgi - zlib extra-deps: - - cgi-3001.5.0.1 - - http3-0.0.16 - - multipart-0.2.1 + - http3-0.0.18 - network-udp-0.0.0 - - quic-0.2.1 + - quic-0.2.2 - sockaddr-0.0.1 diff --git a/stack.yaml b/stack.yaml index 6b19a4193..0241fb7d0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.31 +resolver: lts-22.39 packages: - ./auto-update - ./mime-types