auto-update 0.1.0.0 → 0.2.6
raw patch · 16 files changed
Files
- ChangeLog.md +76/−0
- Control/AutoUpdate.hs +55/−169
- Control/AutoUpdate/Event.hs +124/−0
- Control/AutoUpdate/Internal.hs +11/−0
- Control/AutoUpdate/Thread.hs +133/−0
- Control/AutoUpdate/Types.hs +49/−0
- Control/Debounce.hs +70/−0
- Control/Debounce/Internal.hs +297/−0
- Control/Reaper.hs +326/−0
- Control/Reaper/Internal.hs +28/−0
- README.md +11/−3
- Setup.hs +1/−0
- auto-update.cabal +23/−7
- test/Control/AutoUpdateSpec.hs +29/−26
- test/Control/DebounceSpec.hs +226/−0
- test/Control/ReaperSpec.hs +40/−0
+ ChangeLog.md view
@@ -0,0 +1,76 @@+# ChangeLog for auto-update++## 0.2.6++* Using the thread version of AutoUpdate for non-threaded RTS.+ [#1020](https://github.com/yesodweb/wai/pull/1020)++## 0.2.5++* Thread less autoupdate+ [#1018](https://github.com/yesodweb/wai/pull/1018)++## 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:+ Names can be given via this field to threads+ for GHC.Conc.Sync.listThreads.++## 0.2.1++* Labeling threads.++## 0.2.0++* Creating Reaper.Internal to export Reaper constructor.+* Hiding Reaper constructor.+* [#985](https://github.com/yesodweb/wai/pull/985):+ Add `reaperModify` to the `Reaper` API, allowing workload modification outside+ of the main `reaperAction` loop.++## 0.1.6++* [#756](https://github.com/yesodweb/wai/pull/756):+ Add control of activation on leading vs. trailing edges for Control.Debounce++## 0.1.5++* [#752](https://github.com/yesodweb/wai/pull/752):+ Using the Strict and StrictData language extensions for GHC >8.++## 0.1.4.1++* [#693](https://github.com/yesodweb/wai/pull/693):+ Improve documentation for `reaperAction` function.+* [#732](https://github.com/yesodweb/wai/pull/732):+ Fixed memory leak in `reaperAdd` function.++## 0.1.4++* Provide updateActionModify API in AutoUpdate [#547](https://github.com/yesodweb/wai/pull/547)++## 0.1.3.1++* Doc improvements++## 0.1.3++* Adding a new AIP - reaperKill++## 0.1.2++* Added Control.Debounce
Control/AutoUpdate.hs view
@@ -1,184 +1,70 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} --- | A common problem is the desire to have an action run at a scheduled--- interval, but only if it is needed. For example, instead of having--- every web request result in a new @getCurrentTime@ call, we'd like to--- have a single worker thread run every second, updating an @IORef@.--- However, if the request frequency is less than once per second, this is--- a pessimization, and worse, kills idle GC.+-- | In a multithreaded environment, sharing results of actions can dramatically improve performance.+-- For example, web servers need to return the current time with each HTTP response.+-- For a high-volume server, it's much faster for a dedicated thread to run every+-- second, and write the current time to a shared 'IORef', than it is for each+-- request to make its own call to 'getCurrentTime'. ----- This library allows you to define actions which will either be--- performed by a dedicated thread or, in times of low volume, will be--- executed by the calling thread.-module Control.AutoUpdate- ( UpdateSettings- , defaultUpdateSettings- , updateFreq- , updateSpawnThreshold- , updateAction- , mkAutoUpdate- ) where--import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)-import Control.Exception (Exception, SomeException- ,assert, fromException, handle,throwIO, throwTo)-import Control.Monad (forever, join)-import Data.IORef (IORef, newIORef)-import Data.Typeable (Typeable)--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#if MIN_VERSION_base(4,6,0)-import Data.IORef (atomicModifyIORef')-#else-import Data.IORef (atomicModifyIORef)--- | Strict version of 'atomicModifyIORef'. This forces both the value stored--- in the 'IORef' as well as the value returned.-atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef' ref f = do- c <- atomicModifyIORef ref- (\x -> let (a, b) = f x -- Lazy application of "f"- in (a, a `seq` b)) -- Lazy application of "seq"- -- The following forces "a `seq` b", so it also forces "f x".- c `seq` return c-#endif---- | Default value for creating an @UpdateSettings@.+-- But for a low-volume server, whose request frequency is less than once per+-- second, that approach will result in /more/ calls to 'getCurrentTime' than+-- necessary, and worse, kills idle GC. ----- Since 0.1.0-defaultUpdateSettings :: UpdateSettings ()-defaultUpdateSettings = UpdateSettings- { updateFreq = 1000000- , updateSpawnThreshold = 3- , updateAction = return ()- }---- | Settings to control how values are updated.+-- This library solves that problem by allowing you to define actions which will+-- either be performed by a dedicated thread, or, in times of low volume, will+-- be executed by the calling thread. ----- This should be constructed using @defaultUpdateSettings@ and record--- update syntax, e.g.:+-- Example usage: -- -- @--- let set = defaultUpdateSettings { updateAction = getCurrentTime }--- @+-- import "Data.Time"+-- import "Control.AutoUpdate" ----- Since 0.1.0-data UpdateSettings a = UpdateSettings- { updateFreq :: Int- -- ^ Microseconds between update calls. Same considerations as- -- @threadDelay@ apply.- --- -- Default: 1 second (1000000)- --- -- Since 0.1.0- , updateSpawnThreshold :: Int- -- ^ How many times the data must be requested before we decide to- -- spawn a dedicated thread.- --- -- Default: 3- --- -- Since 0.1.0- , updateAction :: IO a- -- ^ Action to be performed to get the current value.- --- -- Default: does nothing.- --- -- Since 0.1.0- }--data Status a = AutoUpdated- !a- {-# UNPACK #-} !Int- -- Number of times used since last updated.- {-# UNPACK #-} !ThreadId- -- Worker thread.- | ManualUpdates- {-# UNPACK #-} !Int- -- Number of times used since we started/switched- -- off manual updates.---- | Generate an action which will either read from an automatically--- updated value, or run the update action in the current thread.+-- getTime <- 'mkAutoUpdate' 'defaultUpdateSettings'+-- { 'updateAction' = 'Data.Time.Clock.getCurrentTime'+-- , 'updateFreq' = 1000000 -- The default frequency, once per second+-- }+-- currentTime <- getTime+-- @ ----- Since 0.1.0-mkAutoUpdate :: UpdateSettings a -> IO (IO a)-mkAutoUpdate (UpdateSettings !f !t !a) = do- istatus <- newIORef $ ManualUpdates 0- return $! getCurrent f t a istatus--data Action a = Return a | Manual | Spawn+-- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>.+module Control.AutoUpdate (+ -- * Type+ UpdateSettings,+ defaultUpdateSettings, -data Replaced = Replaced deriving (Show, Typeable)-instance Exception Replaced+ -- * Accessors+ updateAction,+ updateFreq,+ updateSpawnThreshold,+ updateThreadName, --- | Get the current value, either fed from an auto-update thread, or--- computed manually in the current thread.------ Since 0.1.0-getCurrent :: Int -- ^ frequency- -> Int -- ^ spawn threshold- -> IO a -- ^ internal update action- -> IORef (Status a) -- ^ mutable state- -> IO a-getCurrent freq spawnThreshold update istatus = do- ea <- atomicModifyIORef' istatus increment- case ea of- Return a -> return a- Manual -> update- Spawn -> do- a <- update- tid <- forkIO $ spawn freq update istatus- join $ atomicModifyIORef' istatus $ turnToAuto a tid- return a- where- increment (AutoUpdated a cnt tid) = (AutoUpdated a (succ cnt) tid, Return a)- increment (ManualUpdates i) = (ManualUpdates (succ i), act)- where- act = if i > spawnThreshold then Spawn else Manual+ -- * Creation+ mkAutoUpdate,+ mkAutoUpdateWithModify,+)+where - -- Normal case.- turnToAuto a tid (ManualUpdates cnt) = (AutoUpdated a cnt tid- ,return ())- -- Race condition: multiple threads were spawned.- -- So, let's kill the previous one by this thread.- turnToAuto a tid (AutoUpdated _ cnt old) = (AutoUpdated a cnt tid- ,throwTo old Replaced)+import Control.AutoUpdate.Types+#ifdef mingw32_HOST_OS+import Control.AutoUpdate.Thread+#else+import qualified Control.AutoUpdate.Event as Event+import qualified Control.AutoUpdate.Thread as Thread -spawn :: Int -> IO a -> IORef (Status a) -> IO ()-spawn freq update istatus = handle (onErr istatus) $ forever $ do- threadDelay freq- a <- update- join $ atomicModifyIORef' istatus $ turnToManual a- where- -- Normal case.- turnToManual a (AutoUpdated _ cnt tid)- | cnt >= 1 = (AutoUpdated a 0 tid, return ())- | otherwise = (ManualUpdates 0, stop)- -- This case must not happen.- turnToManual _ (ManualUpdates i) = assert False (ManualUpdates i, stop)+import GHC.Event -onErr :: IORef (Status a) -> SomeException -> IO ()-onErr istatus ex = case fromException ex of- Just Replaced -> return ()- Nothing -> do- tid <- myThreadId- atomicModifyIORef' istatus $ clear tid- throwIO ex- where- -- In the race condition described above,- -- suppose thread A is running, and is killed by thread B.- -- Thread B then updates the IORef to refer to thread B.- -- Then thread A's exception handler fires.- -- We don't want to modify the IORef at all,- -- since it refers to thread B already.- -- Solution: only switch back to manual updates- -- if the IORef is pointing at the current thread.- clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())- clear _ status = (status, ())+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate settings = do+ mmgr <- getSystemEventManager+ case mmgr of+ Nothing -> Thread.mkAutoUpdate settings+ Just _m -> Event.mkAutoUpdate settings -stop :: IO a-stop = throwIO Replaced+mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)+mkAutoUpdateWithModify settings f = do+ mmgr <- getSystemEventManager+ case mmgr of+ Nothing -> Thread.mkAutoUpdateWithModify settings f+ Just _m -> Event.mkAutoUpdateWithModify settings f+#endif
+ Control/AutoUpdate/Event.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE RecordWildCards #-}++module Control.AutoUpdate.Event (+ -- * Creation+ mkAutoUpdate,+ mkAutoUpdateWithModify,++ -- * Internal+ UpdateState (..),+ mkClosableAutoUpdate,+ mkClosableAutoUpdate',+)+where++import Control.Concurrent.STM+import Control.Monad+import Data.IORef+import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout)++import Control.AutoUpdate.Types++--------------------------------------------------------------------------------++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread.+--+-- @since 0.1.0+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread if+-- the first time or the provided modify action after that.+--+-- @since 0.1.4+mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)+mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f++--------------------------------------------------------------------------------++{- FOURMOLU_DISABLE -}+data UpdateState a =+ UpdateState+ { usUpdateAction_ :: a -> IO a+ , usLastResult_ :: IORef a+ , usIntervalMicro_ :: Int+ , usTimeHasCome_ :: TVar Bool+ , usDeleteTimeout_ :: IORef (IO ())+ }+{- FOURMOLU_ENABLE -}++--------------------------------------------------------------------------------++mkAutoUpdateThings+ :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b+mkAutoUpdateThings mk settings@UpdateSettings{..} =+ mkAutoUpdateThingsWithModify mk settings (const updateAction)++mkAutoUpdateThingsWithModify+ :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> (a -> IO a) -> IO b+mkAutoUpdateThingsWithModify mk settings update1 = do+ us <- openUpdateState settings update1+ pure $ mk (getUpdateResult us) (closeUpdateState us) us++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -XNumericUnderscores+-- >>> import Control.Concurrent++-- |+-- >>> iref <- newIORef (0 :: Int)+-- >>> action = modifyIORef iref (+ 1) >> readIORef iref+-- >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action }+-- >>> getValue+-- 1+-- >>> threadDelay 100_000 >> getValue+-- 1+-- >>> threadDelay 200_000 >> getValue+-- 2+-- >>> closeState+mkClosableAutoUpdate :: UpdateSettings a -> IO (IO a, IO ())+mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c)++-- | provide `UpdateState` for debugging+mkClosableAutoUpdate' :: UpdateSettings a -> IO (IO a, IO (), UpdateState a)+mkClosableAutoUpdate' = mkAutoUpdateThings (,,)++--------------------------------------------------------------------------------++mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ())+mkDeleteTimeout thc micro = do+ mgr <- getSystemTimerManager+ key <- registerTimeout mgr micro (atomically $ writeTVar thc True)+ pure $ unregisterTimeout mgr key++openUpdateState :: UpdateSettings a -> (a -> IO a) -> IO (UpdateState a)+openUpdateState UpdateSettings{..} update1 = do+ thc <- newTVarIO False+ UpdateState update1+ <$> (newIORef =<< updateAction)+ <*> pure updateFreq+ <*> pure thc+ <*> (newIORef =<< mkDeleteTimeout thc updateFreq)++closeUpdateState :: UpdateState a -> IO ()+closeUpdateState UpdateState{..} = do+ delete <- readIORef usDeleteTimeout_+ delete++onceOnTimeHasCome :: UpdateState a -> IO () -> IO ()+onceOnTimeHasCome UpdateState{..} action = do+ action' <- atomically $ do+ timeHasCome <- readTVar usTimeHasCome_+ when timeHasCome $ writeTVar usTimeHasCome_ False+ pure $ when timeHasCome action+ action'++getUpdateResult :: UpdateState a -> IO a+getUpdateResult us@UpdateState{..} = do+ onceOnTimeHasCome us $ do+ writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_+ writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_+ readIORef usLastResult_
+ Control/AutoUpdate/Internal.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++module Control.AutoUpdate.Internal (+ -- * Debugging+ UpdateState (..),+ mkClosableAutoUpdate,+ mkClosableAutoUpdate',+)+where++import Control.AutoUpdate.Event
+ Control/AutoUpdate/Thread.hs view
@@ -0,0 +1,133 @@+module Control.AutoUpdate.Thread (+ -- * Creation+ mkAutoUpdate,+ mkAutoUpdateWithModify,+) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (+ newEmptyMVar,+ putMVar,+ readMVar,+ takeMVar,+ tryPutMVar,+ )+import Control.Exception (+ SomeException,+ catch,+ mask_,+ throw,+ try,+ )+import Control.Monad (void)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import GHC.Conc.Sync (labelThread)++import Control.AutoUpdate.Types++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread.+--+-- @since 0.1.0+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate us = mkAutoUpdateHelper us Nothing++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread if+-- the first time or the provided modify action after that.+--+-- @since 0.1.4+mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)+mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)++mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)+mkAutoUpdateHelper us updateActionModify = do+ -- A baton to tell the worker thread to generate a new value.+ needsRunning <- newEmptyMVar++ -- The initial response variable. Response variables allow the requesting+ -- thread to block until a value is generated by the worker thread.+ responseVar0 <- newEmptyMVar++ -- The current value, if available. We start off with a Left value+ -- indicating no value is available, and the above-created responseVar0 to+ -- give a variable to block on.+ currRef <- newIORef $ Left responseVar0++ -- This is used to set a value in the currRef variable when the worker+ -- thread exits. In reality, that value should never be used, since the+ -- worker thread exiting only occurs if an async exception is thrown, which+ -- should only occur if there are no references to needsRunning left.+ -- However, this handler will make error messages much clearer if there's a+ -- bug in the implementation.+ let fillRefOnExit f = do+ eres <- try f+ case eres of+ Left e ->+ writeIORef currRef $+ error $+ "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "+ ++ show (e :: SomeException)+ Right () ->+ writeIORef currRef $+ error $+ "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "+ ++ "which should be impossible due to usage of infinite loop"++ -- fork the worker thread immediately. Note that we mask async exceptions,+ -- but *not* in an uninterruptible manner. This will allow a+ -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take+ -- down this thread when all references to the returned function are+ -- garbage collected, and therefore there is no thread that can fill the+ -- needsRunning MVar.+ --+ -- Note that since we throw away the ThreadId of this new thread and never+ -- calls myThreadId, normal async exceptions can never be thrown to it,+ -- only RTS exceptions.+ tid <- mask_ $ forkIO $ fillRefOnExit $ do+ -- This infinite loop makes up out worker thread. It takes an a+ -- responseVar value where the next value should be putMVar'ed to for+ -- the benefit of any requesters currently blocked on it.+ let loop responseVar maybea = do+ -- block until a value is actually needed+ takeMVar needsRunning++ -- new value requested, so run the updateAction+ a <- catchSome $ fromMaybe (updateAction us) (updateActionModify <*> maybea)++ -- we got a new value, update currRef and lastValue+ writeIORef currRef $ Right a+ putMVar responseVar a++ -- delay until we're needed again+ threadDelay $ updateFreq us++ -- delay's over. create a new response variable and set currRef+ -- to use it, so that the next requester will block on that+ -- variable. Then loop again with the updated response+ -- variable.+ responseVar' <- newEmptyMVar+ writeIORef currRef $ Left responseVar'+ loop responseVar' (Just a)++ -- Kick off the loop, with the initial responseVar0 variable.+ loop responseVar0 Nothing+ labelThread tid $ updateThreadName us+ return $ do+ mval <- readIORef currRef+ case mval of+ Left responseVar -> do+ -- no current value, force the worker thread to run...+ void $ tryPutMVar needsRunning ()++ -- and block for the result from the worker+ readMVar responseVar+ -- we have a current value, use it+ Right val -> return val++-- | Turn a runtime exception into an impure exception, so that all 'IO'+-- actions will complete successfully. This simply defers the exception until+-- the value is forced.+catchSome :: IO a -> IO a+catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)
+ Control/AutoUpdate/Types.hs view
@@ -0,0 +1,49 @@+module Control.AutoUpdate.Types where++-- | Settings to control how values are updated.+--+-- This should be constructed using 'defaultUpdateSettings' and record+-- update syntax, e.g.:+--+-- @+-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }+-- @+--+-- @since 0.1.0+data UpdateSettings a = UpdateSettings+ { updateFreq :: Int+ -- ^ Microseconds between update calls. Same considerations as+ -- 'threadDelay' apply.+ --+ -- Default: 1000000 microseconds (1 second)+ --+ -- @since 0.1.0+ , updateSpawnThreshold :: Int+ -- ^ Obsoleted field.+ --+ -- @since 0.1.0+ , updateAction :: IO a+ -- ^ Action to be performed to get the current value.+ --+ -- Default: does nothing.+ --+ -- @since 0.1.0+ , updateThreadName :: String+ -- ^ Label of the thread being forked.+ --+ -- Default: @"AutoUpdate"@+ --+ -- @since 0.2.2+ }++-- | Default value for creating an 'UpdateSettings'.+--+-- @since 0.1.0+defaultUpdateSettings :: UpdateSettings ()+defaultUpdateSettings =+ UpdateSettings+ { updateFreq = 1000000+ , updateSpawnThreshold = 3+ , updateAction = return ()+ , updateThreadName = "AutoUpdate"+ }
+ Control/Debounce.hs view
@@ -0,0 +1,70 @@+-- | Debounce an action, ensuring it doesn't occur more than once for a given+-- period of time.+--+-- This is useful as an optimization, for example to ensure that logs are only+-- flushed to disk at most once per second.+--+-- Example usage:+--+-- @+-- > printString <- 'mkDebounce' 'defaultDebounceSettings'+-- { 'debounceAction' = putStrLn "Running action"+-- , 'debounceFreq' = 5000000 -- 5 seconds+-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge+-- }+-- > printString+-- Running action+-- > printString+-- \<Wait five seconds>+-- Running action+-- @+--+-- See the fast-logger package ("System.Log.FastLogger") for real-world usage.+--+-- @since 0.1.2+module Control.Debounce (+ -- * Creation+ mkDebounce,++ -- * Settings+ DI.DebounceSettings,+ defaultDebounceSettings,++ -- ** Accessors+ DI.debounceFreq,+ DI.debounceAction,+ DI.debounceEdge,+ DI.debounceThreadName,++ -- ** Edge types+ DI.leadingEdge,+ DI.leadingMuteEdge,+ DI.trailingEdge,+ DI.trailingDelayEdge,+) where++import Control.Concurrent (newMVar, threadDelay)+import qualified Control.Debounce.Internal as DI++-- | Default value for creating a 'DebounceSettings'.+--+-- @since 0.1.2+defaultDebounceSettings :: DI.DebounceSettings+defaultDebounceSettings =+ DI.DebounceSettings+ { DI.debounceFreq = 1000000+ , DI.debounceAction = return ()+ , DI.debounceEdge = DI.leadingEdge+ , DI.debounceThreadName = "Debounce"+ }++-- | 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 <- newMVar ()+ DI.mkDebounceInternal baton threadDelay settings
+ Control/Debounce/Internal.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Unstable API which exposes internals for testing.+module Control.Debounce.Internal (+ DebounceSettings (..),+ DebounceEdge (..),+ leadingEdge,+ leadingMuteEdge,+ trailingEdge,+ trailingDelayEdge,+ mkDebounceInternal,+) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (+ MVar,+ newEmptyMVar,+ putMVar,+ tryPutMVar,+ tryTakeMVar,+ )+import Control.Exception (SomeException, handle, mask_)+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.+--+-- This should be constructed using 'defaultDebounceSettings' and record+-- update syntax, e.g.:+--+-- @+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }+-- @+--+-- @since 0.1.2+data DebounceSettings = DebounceSettings+ { debounceFreq :: Int+ -- ^ Length of the debounce timeout period in microseconds.+ --+ -- Default: 1 second (1000000)+ --+ -- @since 0.1.2+ , debounceAction :: IO ()+ -- ^ Action to be performed.+ --+ -- Note: all exceptions thrown by this action will be silently discarded.+ --+ -- Default: does nothing.+ --+ -- @since 0.1.2+ , debounceEdge :: DebounceEdge+ -- ^ Whether to perform the action on the leading edge or trailing edge of+ -- the timeout.+ --+ -- 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+-- edge of the timeout.+--+-- @since 0.1.6+data DebounceEdge+ = -- | 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.+ 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++-- | 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) =+ 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 ()
+ Control/Reaper.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-- | This module provides the ability to create reapers: dedicated cleanup+-- threads. These threads will automatically spawn and die based on the+-- presence of a workload to process on. Example uses include:+--+-- * Killing long-running jobs+-- * Closing unused connections in a connection pool+-- * Pruning a cache of old items (see example below)+--+-- For real-world usage, search the <https://github.com/yesodweb/wai WAI family of packages>+-- for imports of "Control.Reaper".+module Control.Reaper (+ -- * Example: Regularly cleaning a cache+ -- $example1++ -- * Settings+ ReaperSettings,+ defaultReaperSettings,++ -- * Accessors+ reaperAction,+ reaperDelay,+ reaperCons,+ reaperNull,+ reaperEmpty,+ reaperThreadName,++ -- * Type+ Reaper,+ reaperAdd,+ reaperRead,+ reaperModify,+ reaperStop,+ reaperKill,++ -- * Creation+ mkReaper,++ -- * Helper+ mkListAction,+) where++import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)+import Control.Exception (mask_)+import Control.Reaper.Internal+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import GHC.Conc.Sync (labelThread)++-- | Settings for creating a reaper. This type has two parameters:+-- @workload@ gives the entire workload, whereas @item@ gives an+-- individual piece of the queue. A common approach is to have @workload@+-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and+-- 'mkListAction'.+--+-- @since 0.1.1+data ReaperSettings workload item = ReaperSettings+ { reaperAction :: workload -> IO (workload -> workload)+ -- ^ The action to perform on a workload. The result of this is a+ -- \"workload modifying\" function. In the common case of using lists,+ -- the result should be a difference list that prepends the remaining+ -- workload to the temporary workload. The temporary workload here+ -- refers to items added to the workload while the reaper action is+ -- running. For help with setting up such an action, see 'mkListAction'.+ --+ -- Default: do nothing with the workload, and then prepend it to the+ -- temporary workload. This is incredibly useless; you should+ -- definitely override this default.+ --+ -- @since 0.1.1+ , reaperDelay :: {-# UNPACK #-} !Int+ -- ^ Number of microseconds to delay between calls of 'reaperAction'.+ --+ -- Default: 30 seconds.+ --+ -- @since 0.1.1+ , reaperCons :: item -> workload -> workload+ -- ^ Add an item onto a workload.+ --+ -- Default: list consing.+ --+ -- @since 0.1.1+ , reaperNull :: workload -> Bool+ -- ^ Check if a workload is empty, in which case the worker thread+ -- will shut down.+ --+ -- Default: 'null'.+ --+ -- @since 0.1.1+ , reaperEmpty :: workload+ -- ^ An empty workload.+ --+ -- Default: empty list.+ --+ -- @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+-- items.+--+-- @since 0.1.1+defaultReaperSettings :: ReaperSettings [item] item+defaultReaperSettings =+ ReaperSettings+ { reaperAction = \wl -> return (wl ++)+ , reaperDelay = 30000000+ , reaperCons = (:)+ , reaperNull = null+ , reaperEmpty = []+ , reaperThreadName = "Reaper"+ }++-- | State of reaper.+data State workload+ = -- | No reaper thread+ NoReaper+ | -- | The current jobs+ Workload !workload++-- | Create a reaper addition function. This function can be used to add+-- new items to the workload. Spawning of reaper threads will be handled+-- for you automatically.+--+-- @since 0.1.1+mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)+mkReaper settings@ReaperSettings{..} = do+ stateRef <- newIORef NoReaper+ tidRef <- newIORef Nothing+ return+ Reaper+ { reaperAdd = add settings stateRef tidRef+ , reaperRead = readRef stateRef+ , reaperModify = modifyRef stateRef+ , reaperStop = stop stateRef+ , reaperKill = kill tidRef+ }+ where+ readRef stateRef = do+ mx <- readIORef stateRef+ case mx of+ NoReaper -> return reaperEmpty+ Workload wl -> return wl+ modifyRef stateRef modifier = atomicModifyIORef' stateRef $ \mx ->+ case mx of+ NoReaper ->+ (NoReaper, reaperEmpty)+ Workload wl ->+ let !wl' = modifier wl+ in (Workload wl', wl')+ stop stateRef = atomicModifyIORef' stateRef $ \mx ->+ case mx of+ NoReaper -> (NoReaper, reaperEmpty)+ Workload x -> (Workload reaperEmpty, x)+ kill tidRef = do+ mtid <- readIORef tidRef+ case mtid of+ Nothing -> return ()+ Just tid -> killThread tid++add+ :: ReaperSettings workload item+ -> IORef (State workload)+ -> IORef (Maybe ThreadId)+ -> item+ -> IO ()+add settings@ReaperSettings{..} stateRef tidRef item =+ mask_ $ do+ next <- atomicModifyIORef' stateRef cons+ next+ where+ cons NoReaper =+ let wl = reaperCons item reaperEmpty+ in (Workload wl, spawn settings stateRef tidRef)+ cons (Workload wl) =+ let wl' = reaperCons item wl+ in (Workload wl', return ())++spawn+ :: ReaperSettings workload item+ -> IORef (State workload)+ -> IORef (Maybe ThreadId)+ -> IO ()+spawn settings stateRef tidRef = do+ tid <- forkIO $ reaper settings stateRef tidRef+ labelThread tid $ reaperThreadName settings+ writeIORef tidRef $ Just tid++reaper+ :: ReaperSettings workload item+ -> IORef (State workload)+ -> IORef (Maybe ThreadId)+ -> IO ()+reaper settings@ReaperSettings{..} stateRef tidRef = do+ threadDelay reaperDelay+ -- Getting the current jobs. Push an empty job to the reference.+ wl <- atomicModifyIORef' stateRef swapWithEmpty+ -- Do the jobs. A function to merge the left jobs and+ -- new jobs is returned.+ !merge <- reaperAction wl+ -- Merging the left jobs and new jobs.+ -- If there is no jobs, this thread finishes.+ 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)++ check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"+ check merge (Workload wl)+ -- If there is no job, reaper is terminated.+ | reaperNull wl' = (NoReaper, False)+ -- If there are jobs, carry them out.+ | otherwise = (Workload wl', True)+ where+ wl' = merge wl++-- | A helper function for creating 'reaperAction' functions. You would+-- provide this function with a function to process a single work item and+-- return either a new work item, or @Nothing@ if the work item is+-- expired.+--+-- @since 0.1.1+mkListAction+ :: (item -> IO (Maybe item'))+ -> [item]+ -> IO ([item'] -> [item'])+mkListAction f =+ go id+ where+ go !front [] = return front+ go !front (x : xs) = do+ my <- f x+ let front' =+ case my of+ Nothing -> front+ Just y -> front . (y :)+ go front' xs++-- $example1+-- In this example code, we use a 'Data.Map.Strict.Map' to cache fibonacci numbers, and a 'Reaper' to prune the cache.+--+-- NOTE: When using this module as a cache you should keep in mind that while+-- the reaper thread is active running your "reaperAction", the cache will+-- appear empty to concurrently running threads. Any newly created cache+-- entries will be on the temporary worklist, and will merged back into the the+-- main cache only once the "reaperAction" completes (together with the portion+-- of the extant worklist that the @cleaner@ callback decided to retain).+--+-- If you're looking for a cache that supports concurrent purging of stale+-- items, but without exposing a transient empty cache during cleanup, this is+-- not the cache implementation you need. This module was primarily designed+-- for cleaning up /stuck/ processes, or idle threads in a thread pool. The cache+-- use-case was not a primary design focus.+--+-- The @main@ function first creates a 'Reaper', with fields to initialize the+-- cache ('reaperEmpty'), add items to it ('reaperCons'), and prune it ('reaperAction').+-- The reaper will run every two seconds ('reaperDelay'), but will stop running while+-- 'reaperNull' is true.+--+-- @main@ then loops infinitely ('Control.Monad.forever'). Each second it calculates the fibonacci number+-- for a value between 30 and 34, first trying the cache ('reaperRead' and 'Data.Map.Strict.lookup'),+-- then falling back to manually calculating it (@fib@)+-- and updating the cache with the result ('reaperAdd')+--+-- @clean@ simply removes items cached for more than 10 seconds.+-- This function is where you would perform IO-related cleanup,+-- like killing threads or closing connections, if that was the purpose of your reaper.+--+-- @+-- module Main where+--+-- import "Data.Time" (UTCTime, getCurrentTime, diffUTCTime)+-- import "Control.Reaper"+-- import "Control.Concurrent" (threadDelay)+-- import "Data.Map.Strict" (Map)+-- import qualified "Data.Map.Strict" as Map+-- import "Control.Monad" (forever)+-- import "System.Random" (getStdRandom, randomR)+--+-- fib :: 'Int' -> 'Int'+-- fib 0 = 0+-- fib 1 = 1+-- fib n = fib (n-1) + fib (n-2)+--+-- type Cache = 'Data.Map.Strict.Map' 'Int' ('Int', 'Data.Time.Clock.UTCTime')+--+-- main :: IO ()+-- main = do+-- reaper <- 'mkReaper' 'defaultReaperSettings'+-- { 'reaperEmpty' = Map.'Data.Map.Strict.empty'+-- , 'reaperCons' = \\(k, v, time) workload -> Map.'Data.Map.Strict.insert' k (v, time) workload+-- , 'reaperAction' = clean+-- , 'reaperDelay' = 1000000 * 2 -- Clean every 2 seconds+-- , 'reaperNull' = Map.'Data.Map.Strict.null'+-- }+-- forever $ do+-- fibArg <- 'System.Random.getStdRandom' ('System.Random.randomR' (30,34))+-- cache <- 'reaperRead' reaper+-- let cachedResult = Map.'Data.Map.Strict.lookup' fibArg cache+-- case cachedResult of+-- 'Just' (fibResult, _createdAt) -> 'putStrLn' $ "Found in cache: `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult+-- 'Nothing' -> do+-- let fibResult = fib fibArg+-- 'putStrLn' $ "Calculating `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult+-- time <- 'Data.Time.Clock.getCurrentTime'+-- ('reaperAdd' reaper) (fibArg, fibResult, time)+-- 'threadDelay' 1000000 -- 1 second+--+-- -- Remove items > 10 seconds old+-- clean :: Cache -> IO (Cache -> Cache)+-- clean oldMap = do+-- currentTime <- 'Data.Time.Clock.getCurrentTime'+-- let pruned = Map.'Data.Map.Strict.filter' (\\(_, createdAt) -> currentTime \`diffUTCTime\` createdAt < 10.0) oldMap+-- return (\\newData -> Map.'Data.Map.Strict.union' pruned newData)+-- @
+ Control/Reaper/Internal.hs view
@@ -0,0 +1,28 @@+module Control.Reaper.Internal (Reaper (..)) where++-- | A data structure to hold reaper APIs.+data Reaper workload item = Reaper+ { reaperAdd :: item -> IO ()+ -- ^ Adding an item to the workload+ , reaperRead :: IO workload+ -- ^ Reading workload.+ , reaperModify :: (workload -> workload) -> IO workload+ -- ^ Modify the workload. The resulting workload is returned.+ --+ -- If there is no reaper thread, the modifier will not be applied and+ -- 'reaperEmpty' will be returned.+ --+ -- If the reaper is currently executing jobs, those jobs will not be in+ -- the given workload and the workload might appear empty.+ --+ -- If all jobs are removed by the modifier, the reaper thread will not be+ -- killed. The reaper thread will only terminate if 'reaperKill' is called+ -- or the result of 'reaperAction' satisfies 'reaperNull'.+ --+ -- @since 0.2.0+ , reaperStop :: IO workload+ -- ^ Stopping the reaper thread if exists.+ -- The current workload is returned.+ , reaperKill :: IO ()+ -- ^ Killing the reaper thread immediately if exists.+ }
README.md view
@@ -1,5 +1,13 @@-See https://github.com/yesodweb/yesod-scaffold/pull/15+## auto-update -Todo:+A common problem is the desire to have an action run at a scheduled interval,+but only if it is needed. For example, instead of having every web request+result in a new `getCurrentTime` call, we'd like to have a single worker thread+run every second, updating an `IORef`. However, if the request frequency is+less than once per second, this is a pessimization, and worse, kills idle GC. -- Add ThreadId to prevent race condition.+This library allows you to define actions which will either be performed by a+dedicated thread or, in times of low volume, will be executed by the calling+thread.++For original use case, see [yesod-scaffold issue #15](https://github.com/yesodweb/yesod-scaffold/pull/15).
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
auto-update.cabal view
@@ -1,10 +1,7 @@ name: auto-update-version: 0.1.0.0+version: 0.2.6 synopsis: Efficiently run periodic, on-demand actions-description:- A common problem is the desire to have an action run at a scheduled interval, but only if it is needed. For example, instead of having every web request result in a new @getCurrentTime@ call, we'd like to have a single worker thread run every second, updating an @IORef@. However, if the request frequency is less than once per second, this is a pessimization, and worse, kills idle GC.- .- This library allows you to define actions which will either be performed by a dedicated thread or, in times of low volume, will be executed by the calling thread.+description: API docs and the README are available at <http://www.stackage.org/package/auto-update>. homepage: https://github.com/yesodweb/wai license: MIT license-file: LICENSE@@ -13,17 +10,36 @@ category: Control build-type: Simple extra-source-files: README.md+ ChangeLog.md cabal-version: >=1.10 library+ ghc-options: -Wall exposed-modules: Control.AutoUpdate- build-depends: base >= 4 && < 5+ Control.Debounce+ Control.Debounce.Internal+ Control.Reaper+ Control.Reaper.Internal+ other-modules: Control.AutoUpdate.Types+ Control.AutoUpdate.Thread+ if !os(windows)+ exposed-modules: Control.AutoUpdate.Internal+ other-modules: Control.AutoUpdate.Event+ build-depends: base >= 4.12 && < 5,+ stm default-language: Haskell2010+ if impl(ghc >= 8)+ default-extensions: Strict StrictData +-- Test suite is currently not robust enough, gives too many false negatives.+ test-suite spec main-is: Spec.hs other-modules: Control.AutoUpdateSpec+ Control.DebounceSpec+ Control.ReaperSpec hs-source-dirs: test type: exitcode-stdio-1.0- build-depends: base, auto-update, hspec+ build-depends: base, auto-update, exceptions, hspec, retry, HUnit+ build-tool-depends: hspec-discover:hspec-discover default-language: Haskell2010
test/Control/AutoUpdateSpec.hs view
@@ -1,34 +1,37 @@ module Control.AutoUpdateSpec (spec) where +-- import Control.AutoUpdate+-- import Control.Concurrent (threadDelay)+-- import Control.Monad (replicateM_, forM_)+-- import Data.IORef import Test.Hspec-import Test.Hspec.QuickCheck-import Data.IORef-import Control.Concurrent (threadDelay)-import Control.Monad (replicateM_, forM_)-import Control.AutoUpdate +-- import Test.Hspec.QuickCheck+ spec :: Spec-spec = do- prop "incrementer" $ \st' -> do- let st = abs st'- ref <- newIORef 0- next <- mkAutoUpdate defaultUpdateSettings- { updateAction = atomicModifyIORef ref $ \i ->- let i' = succ i in i' `seq` (i', i')- , updateSpawnThreshold = st- , updateFreq = 10000- }+spec = return () - forM_ [1..st + 1] $ \i -> do- j <- next- j `shouldBe` i+-- do+-- prop "incrementer" $ \st' -> do+-- let st = abs st' `mod` 10000+-- ref <- newIORef 0+-- next <- mkAutoUpdate defaultUpdateSettings+-- { updateAction = atomicModifyIORef ref $ \i ->+-- let i' = succ i in i' `seq` (i', i')+-- , updateSpawnThreshold = st+-- , updateFreq = 10000+-- } - replicateM_ 50 $ do- i <- next- i `shouldBe` st + 2+-- forM_ [1..st + 1] $ \i -> do+-- j <- next+-- j `shouldBe` i - threadDelay 60000- last1 <- readIORef ref- threadDelay 20000- last2 <- readIORef ref- last2 `shouldBe` last1+-- replicateM_ 50 $ do+-- i <- next+-- i `shouldBe` st + 2++-- threadDelay 60000+-- last1 <- readIORef ref+-- threadDelay 20000+-- last2 <- readIORef ref+-- last2 `shouldBe` last1
+ test/Control/DebounceSpec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE NumericUnderscores #-}+module Control.DebounceSpec (main, spec) where++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 (void)+import Control.Monad.Catch+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+ describe "Leading edge" $ do+ it "works for a single event" $ do+ (ref, debounced, _baton, returnFromWait) <- getDebounce leadingEdge++ 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 leadingEdge++ debounced+ waitForBatonToBeTaken baton+ debounced+ pause+ waitUntil 5 $ readIORef ref `shouldReturn` 1++ 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+ readIORef ref `shouldReturn` 0++ returnFromWait+ waitUntil 5 $ readIORef ref `shouldReturn` 1++ -- Try another round+ debounced+ pause+ waitUntil 5 $ readIORef ref `shouldReturn` 1++ returnFromWait+ waitUntil 5 $ readIORef ref `shouldReturn` 2++ it "works for multiple events" $ do+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge++ debounced+ waitForBatonToBeTaken baton+ debounced+ pause+ 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+ waitVar <- newEmptyMVar+ let waitAction _ = takeMVar waitVar+ let returnFromWait = putMVar waitVar ()+ return (waitAction, returnFromWait)++getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())+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) <-+ if useThreadDelay+ then pure (threadDelay, pure ())+ else getWaitAction++ baton <- newMVar ()++ debounced <-+ DI.mkDebounceInternal+ baton+ waitAction+ defaultDebounceSettings+ { debounceFreq = 1_000_000 -- !!! used in 'TrailingDelay' test+ , debounceAction = action+ , debounceEdge = edge+ }++ return (ref, debounced, baton, returnFromWait)++-- | Pause briefly (100ms)+pause :: IO ()+pause = threadDelay 100_000++waitForBatonToBeTaken :: MVar () -> IO ()+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)+ where+ policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds+ handler _status = Handler (\HUnitFailure{} -> return True)++main :: IO ()+main = hspec spec
+ test/Control/ReaperSpec.hs view
@@ -0,0 +1,40 @@+module Control.ReaperSpec (spec) where++-- import Control.Concurrent+-- import Control.Reaper+-- import Data.IORef+import Test.Hspec++-- import Test.Hspec.QuickCheck++spec :: Spec+spec = return ()++-- prop "works" $ \is -> do+-- reaper <- mkReaper defaultReaperSettings+-- { reaperAction = action+-- , reaperDelay = 1000+-- }++-- let mkTestCase i = do+-- ref <- newIORef 0+-- let expected = (abs i `mod` 10) + 1+-- reaperAdd reaper (expected, ref)+-- return (expected, ref)+-- testCases <- mapM mkTestCase is++-- let test (expected, ref) = do+-- actual <- readIORef ref+-- actual `shouldBe` (expected :: Int)+-- threadDelay 100000+-- mapM_ test testCases+-- [] <- reaperRead reaper+-- return ()++-- type Item = (Int, IORef Int)++-- action = mkListAction $ \(i, ref) -> do+-- modifyIORef ref succ+-- return $ if i > 1+-- then Just (pred i, ref)+-- else Nothing