auto-update 0.2.2 → 0.2.4

raw patch · 7 files changed

+384/−54 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +20/−6
• Control/AutoUpdate.hs +5/−0
• Control/Debounce.hs +14/−7
• Control/Debounce/Internal.hs +211/−19
• Control/Reaper.hs +13/−4
• auto-update.cabal +1/−1
• test/Control/DebounceSpec.hs +120/−17

@@ -1,5 +1,19 @@ # ChangeLog for auto-update +## 0.2.4++* Simple refactoring.++## 0.2.3++* [#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.2  * NewAPI: updateThreadName, reaperThreadName, debounceThreadName:@@ -14,19 +28,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 

@@ -115,6 +115,11 @@     --     -- @since 0.1.0     , updateThreadName :: String+    -- ^ Label of the thread being forked.+    --+    -- Default: @"AutoUpdate"@+    --+    -- @since 0.2.2     }  -- | Generate an action which will either read from an automatically

@@ -23,23 +23,27 @@ -- -- @since 0.1.2 module Control.Debounce (-    -- * Type+    -- * Creation+    mkDebounce,++    -- * Settings     DI.DebounceSettings,     defaultDebounceSettings, -    -- * Accessors+    -- ** Accessors     DI.debounceFreq,     DI.debounceAction,     DI.debounceEdge,     DI.debounceThreadName,++    -- ** 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'.@@ -56,8 +60,11 @@  -- | 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

@@ -5,19 +5,24 @@     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,10 +54,15 @@     -- ^ Whether to perform the action on the leading edge or trailing edge of     -- the timeout.     ---    -- Default: 'trailingEdge'.+    -- Default: 'leadingEdge'.     --     -- @since 0.1.6     , debounceThreadName :: String+    -- ^ Label of the thread spawned when debouncing.+    --+    -- Default: @"Debounce"@.+    --+    -- @since 0.2.2     }  -- | Setting to control whether the action happens at the leading and/or trailing@@ -64,42 +74,224 @@       -- 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 name) = do-    tid <- mask_ $ forkIO $ forever $ do-        takeMVar baton-        case edge of-            Leading -> do-                ignoreExc action-                delayFn freq-            Trailing -> do-                delayFn freq-                -- Empty the baton of any other activations during the interval-                void $ tryTakeMVar baton-                ignoreExc action-    labelThread tid name-    return $ void $ tryPutMVar baton ()+mkDebounceInternal baton delayFn (DebounceSettings freq action edge name) =+    case edge of+        Leading -> leadingDebounce <$> newEmptyMVar+        LeadingMute -> pure leadingMuteDebounce+        Trailing -> pure trailingDebounce+        TrailingDelay -> trailingDelayDebounce <$> newTVarIO minBound+  where+    -- 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+    leadingDebounce trigger = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> void $ tryPutMVar trigger ()+            Just () -> do+                void $ tryTakeMVar trigger+                forkAndLabel loop+      where+        loop = do+            -- 3)+            ignoreExc action+            -- 4)+            delayFn freq+            -- 5)+            isTriggered <- tryTakeMVar trigger+            case isTriggered of+                -- 6)+                Nothing -> putMVar baton ()+                Just () -> 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+    leadingMuteDebounce = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> pure ()+            Just () ->+                forkAndLabel $ 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+    trailingDebounce = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> pure ()+            Just () ->+                forkAndLabel $ 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+    trailingDelayDebounce timeTVar = do+        -- 1)+        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 $ loop freq+      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 act = do+        tid <- mask_ $ forkIO act+        labelThread tid name  ignoreExc :: IO () -> IO () ignoreExc = handle $ \(_ :: SomeException) -> return ()

@@ -96,6 +96,11 @@     --     -- @since 0.1.1     , reaperThreadName :: String+    -- ^ Label of the thread spawned by the reaper.+    --+    -- Default: @"Reaper"@.+    --+    -- @since 0.2.2     }  -- | Default @ReaperSettings@ value, biased towards having a list of work@@ -202,8 +207,12 @@     !merge <- reaperAction wl     -- Merging the left jobs and new jobs.     -- If there is no jobs, this thread finishes.-    next <- atomicModifyIORef' stateRef (check merge)-    next+    cont <- atomicModifyIORef' stateRef (check merge)+    if cont+        then+            reaper settings stateRef tidRef+        else+            writeIORef tidRef Nothing   where     swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"     swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl)@@ -211,9 +220,9 @@     check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"     check merge (Workload wl)         -- If there is no job, reaper is terminated.-        | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)+        | reaperNull wl' = (NoReaper, False)         -- If there are jobs, carry them out.-        | otherwise = (Workload wl', reaper settings stateRef tidRef)+        | otherwise = (Workload wl', True)       where         wl' = merge wl 

@@ -1,5 +1,5 @@ name:                auto-update-version:             0.2.2+version:             0.2.4 synopsis:            Efficiently run periodic, on-demand actions description:         API docs and the README are available at <http://www.stackage.org/package/auto-update>. homepage:            https://github.com/yesodweb/wai

@@ -1,14 +1,33 @@+{-# 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 Data.Word (Word64)+import GHC.Clock (getMonotonicTime)+import Test.Hspec (Spec, describe, it, shouldReturn, hspec)+import Test.HUnit (assertBool)+import Test.HUnit.Lang (HUnitFailure (HUnitFailure))  spec :: Spec spec = describe "mkDebounce" $ do@@ -43,14 +62,47 @@             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             (ref, debounced, _baton, returnFromWait) <- getDebounce trailingEdge              debounced             pause-            waitUntil 5 $ readIORef ref `shouldReturn` 0+            readIORef ref `shouldReturn` 0              returnFromWait             waitUntil 5 $ readIORef ref `shouldReturn` 1@@ -70,11 +122,54 @@             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++            start <- getMonotonicTime++            debounced+            readIORef ref `shouldReturn` 0+            -- Asserts at end check that this timing gets added to the cooldown time+            threadDelay 500_000++            readIORef ref `shouldReturn` 0+            before2nd <- getMonotonicTime+            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+            end <- getMonotonicTime+            assertBool "Took less than 1 sec after retrigger" $+                end - before2nd > 1+            assertBool "Took less than 1.5 sec total" $+                end - start > 1.5+ -- | Make a controllable delay function getWaitAction :: IO (p -> IO (), IO ()) getWaitAction = do@@ -83,22 +178,28 @@     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' test                 , debounceAction = action                 , debounceEdge = edge                 }@@ -107,14 +208,16 @@  -- | 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)