diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Control/AutoUpdate.hs b/Control/AutoUpdate.hs --- a/Control/AutoUpdate.hs +++ b/Control/AutoUpdate.hs @@ -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, . +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 diff --git a/Control/AutoUpdate/Event.hs b/Control/AutoUpdate/Event.hs new file mode 100644 --- /dev/null +++ b/Control/AutoUpdate/Event.hs @@ -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_ diff --git a/Control/AutoUpdate/Internal.hs b/Control/AutoUpdate/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/AutoUpdate/Internal.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} + +module Control.AutoUpdate.Internal ( + -- * Debugging + UpdateState (..), + mkClosableAutoUpdate, + mkClosableAutoUpdate', +) +where + +import Control.AutoUpdate.Event diff --git a/Control/AutoUpdate/Thread.hs b/Control/AutoUpdate/Thread.hs new file mode 100644 --- /dev/null +++ b/Control/AutoUpdate/Thread.hs @@ -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) diff --git a/Control/AutoUpdate/Types.hs b/Control/AutoUpdate/Types.hs new file mode 100644 --- /dev/null +++ b/Control/AutoUpdate/Types.hs @@ -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" + } diff --git a/Control/Debounce.hs b/Control/Debounce.hs new file mode 100644 --- /dev/null +++ b/Control/Debounce.hs @@ -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 +-- \ +-- 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 diff --git a/Control/Debounce/Internal.hs b/Control/Debounce/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/Debounce/Internal.hs @@ -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 () diff --git a/Control/Reaper.hs b/Control/Reaper.hs new file mode 100644 --- /dev/null +++ b/Control/Reaper.hs @@ -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 +-- 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) +-- @ diff --git a/Control/Reaper/Internal.hs b/Control/Reaper/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/Reaper/Internal.hs @@ -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. + } diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/auto-update.cabal b/auto-update.cabal --- a/auto-update.cabal +++ b/auto-update.cabal @@ -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 . 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 diff --git a/test/Control/AutoUpdateSpec.hs b/test/Control/AutoUpdateSpec.hs --- a/test/Control/AutoUpdateSpec.hs +++ b/test/Control/AutoUpdateSpec.hs @@ -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 diff --git a/test/Control/DebounceSpec.hs b/test/Control/DebounceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/DebounceSpec.hs @@ -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 diff --git a/test/Control/ReaperSpec.hs b/test/Control/ReaperSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/ReaperSpec.hs @@ -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