diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,14 +1,56 @@ # 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 -* Add control of activation on leading vs. trailing edges for Control.Debounce - [#756](https://github.com/yesodweb/wai/pull/756) +* [#756](https://github.com/yesodweb/wai/pull/756): + Add control of activation on leading vs. trailing edges for Control.Debounce ## 0.1.5 -* Using the Strict and StrictData language extensions for GHC >8. - [#752](https://github.com/yesodweb/wai/pull/752) +* [#752](https://github.com/yesodweb/wai/pull/752): + Using the Strict and StrictData language extensions for GHC >8. ## 0.1.4.1 diff --git a/Control/AutoUpdate.hs b/Control/AutoUpdate.hs --- a/Control/AutoUpdate.hs +++ b/Control/AutoUpdate.hs @@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-} --- | In a multithreaded environment, running actions on a regularly scheduled --- background thread can dramatically improve performance. + +-- | 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'. -- --- 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 +-- 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. -- -- 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 +-- either be performed by a dedicated thread, or, in times of low volume, will -- be executed by the calling thread. -- -- Example usage: @@ -29,173 +29,42 @@ -- -- For more examples, . module Control.AutoUpdate ( - -- * Type - UpdateSettings - , defaultUpdateSettings - -- * Accessors - , updateAction - , updateFreq - , updateSpawnThreshold - -- * Creation - , mkAutoUpdate - , mkAutoUpdateWithModify - ) where + -- * Type + UpdateSettings, + defaultUpdateSettings, -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<*>)) -#endif -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) + -- * Accessors + updateAction, + updateFreq, + updateSpawnThreshold, + updateThreadName, --- | Default value for creating an 'UpdateSettings'. --- --- @since 0.1.0 -defaultUpdateSettings :: UpdateSettings () -defaultUpdateSettings = UpdateSettings - { updateFreq = 1000000 - , updateSpawnThreshold = 3 - , updateAction = return () - } + -- * Creation + mkAutoUpdate, + mkAutoUpdateWithModify, +) +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: 1 second (1000000) - -- - -- @since 0.1.0 - , updateSpawnThreshold :: Int - -- ^ NOTE: This value no longer has any effect, since worker threads are - -- dedicated instead of spawned on demand. - -- - -- Previously, this determined 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 - } +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 --- | 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 +import GHC.Event + mkAutoUpdate :: UpdateSettings a -> IO (IO a) -mkAutoUpdate us = mkAutoUpdateHelper us Nothing +mkAutoUpdate settings = do + mmgr <- getSystemEventManager + case mmgr of + Nothing -> Thread.mkAutoUpdate settings + Just _m -> Event.mkAutoUpdate settings --- | 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. - mask_ $ void $ 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 $ maybe (updateAction us) id (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 - - 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) +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/AutoUpdate/Util.hs b/Control/AutoUpdate/Util.hs deleted file mode 100644 --- a/Control/AutoUpdate/Util.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -module Control.AutoUpdate.Util - ( atomicModifyIORef' - ) where - -#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 (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 diff --git a/Control/Debounce.hs b/Control/Debounce.hs --- a/Control/Debounce.hs +++ b/Control/Debounce.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -- | Debounce an action, ensuring it doesn't occur more than once for a given -- period of time. -- @@ -8,53 +7,64 @@ -- Example usage: -- -- @ --- printString <- 'mkDebounce' 'defaultDebounceSettings' +-- > printString <- 'mkDebounce' 'defaultDebounceSettings' -- { 'debounceAction' = putStrLn "Running action" -- , 'debounceFreq' = 5000000 -- 5 seconds -- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge -- } --- @ --- --- >>> printString +-- > printString -- Running action --- >>> printString --- +-- > printString +-- \ -- Running action +-- @ -- -- See the fast-logger package ("System.Log.FastLogger") for real-world usage. -- -- @since 0.1.2 -module Control.Debounce - ( -- * Type - DI.DebounceSettings - , defaultDebounceSettings - -- * Accessors - , DI.debounceFreq - , DI.debounceAction - , DI.debounceEdge - , DI.leadingEdge - , DI.trailingEdge - -- * Creation - , mkDebounce - ) where +module Control.Debounce ( + -- * Creation + mkDebounce, -import Control.Concurrent (newEmptyMVar, threadDelay) + -- * 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 - } +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 <- newEmptyMVar - DI.mkDebounceInternal baton threadDelay settings + baton <- newMVar () + DI.mkDebounceInternal baton threadDelay settings diff --git a/Control/Debounce/Internal.hs b/Control/Debounce/Internal.hs --- a/Control/Debounce/Internal.hs +++ b/Control/Debounce/Internal.hs @@ -2,17 +2,28 @@ -- | Unstable API which exposes internals for testing. module Control.Debounce.Internal ( - DebounceSettings(..) - , DebounceEdge(..) - , leadingEdge - , trailingEdge - , mkDebounceInternal - ) where + DebounceSettings (..), + DebounceEdge (..), + leadingEdge, + leadingMuteEdge, + trailingEdge, + trailingDelayEdge, + mkDebounceInternal, +) where -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar) -import Control.Exception (SomeException, handle, mask_) -import Control.Monad (forever, void) +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. -- @@ -25,7 +36,7 @@ -- -- @since 0.1.2 data DebounceSettings = DebounceSettings - { debounceFreq :: Int + { debounceFreq :: Int -- ^ Length of the debounce timeout period in microseconds. -- -- Default: 1 second (1000000) @@ -43,56 +54,244 @@ -- ^ Whether to perform the action on the leading edge or trailing edge of -- the timeout. -- - -- Default: 'trailingEdge'. + -- Default: 'leadingEdge'. -- -- @since 0.1.6 + , debounceThreadName :: String + -- ^ Label of the thread spawned when debouncing. + -- + -- Default: @"Debounce"@. + -- + -- @since 0.2.2 } -- | Setting to control whether the action happens at the leading and/or trailing -- edge of the timeout. -- -- @since 0.1.6 -data DebounceEdge = - Leading - -- ^ 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. - | Trailing - -- ^ Start a cooldown period and perform the action when the period ends. If another trigger - -- happens during the cooldown, it has no effect. - deriving (Show, Eq) - +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 --- | Start a cooldown period and perform the action when the period ends. If another trigger --- happens during the cooldown, it has no effect. +-- | Perform the action immediately, and then begin a cooldown period. +-- If the trigger happens again during the cooldown, it is ignored. -- +-- Example of how this style debounce works: +-- +-- > ! = function execution +-- > . = cooldown period +-- > X = debounced code execution +-- > +-- > ! ! ! ! +-- > ....... ....... +-- > X X +-- -- @since 0.1.6 +leadingMuteEdge :: DebounceEdge +leadingMuteEdge = LeadingMute + +-- | Start a cooldown period and perform the action when the period ends. +-- If another trigger happens during the cooldown, it has no effect. +-- +-- Example of how this style debounce works: +-- +-- @ +-- ! = function execution +-- . = cooldown period +-- X = debounced code execution +-- +-- ! ! ! ! +-- ....... ....... +-- X X +-- @ +-- +-- @since 0.1.6 trailingEdge :: DebounceEdge trailingEdge = Trailing -mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ()) -mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do - mask_ $ void $ forkIO $ forever $ do - takeMVar baton - case edge of - Leading -> do +-- | 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 - delayFn freq - Trailing -> do + -- 4) delayFn freq - -- Empty the baton of any other activations during the interval - void $ tryTakeMVar baton - ignoreExc action - - return $ void $ tryPutMVar baton () + -- 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 --- a/Control/Reaper.hs +++ b/Control/Reaper.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# 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 @@ -12,30 +12,41 @@ -- For real-world usage, search the -- for imports of "Control.Reaper". module Control.Reaper ( - -- * Example: Regularly cleaning a cache - -- $example1 + -- * Example: Regularly cleaning a cache + -- $example1 - -- * Settings - ReaperSettings - , defaultReaperSettings - -- * Accessors - , reaperAction - , reaperDelay - , reaperCons - , reaperNull - , reaperEmpty - -- * Type - , Reaper(..) - -- * Creation - , mkReaper - -- * Helper - , mkListAction - ) where + -- * Settings + ReaperSettings, + defaultReaperSettings, -import Control.AutoUpdate.Util (atomicModifyIORef') -import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId) + -- * 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 Data.IORef (IORef, newIORef, readIORef, writeIORef) +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 @@ -83,6 +94,12 @@ -- 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 @@ -90,30 +107,22 @@ -- -- @since 0.1.1 defaultReaperSettings :: ReaperSettings [item] item -defaultReaperSettings = ReaperSettings - { reaperAction = \wl -> return (wl ++) - , reaperDelay = 30000000 - , reaperCons = (:) - , reaperNull = null - , reaperEmpty = [] - } - --- | A data structure to hold reaper APIs. -data Reaper workload item = Reaper { - -- | Adding an item to the workload - reaperAdd :: item -> IO () - -- | Reading workload. - , reaperRead :: IO workload - -- | Stopping the reaper thread if exists. - -- The current workload is returned. - , reaperStop :: IO workload - -- | Killing the reaper thread immediately if exists. - , reaperKill :: IO () - } +defaultReaperSettings = + ReaperSettings + { reaperAction = \wl -> return (wl ++) + , reaperDelay = 30000000 + , reaperCons = (:) + , reaperNull = null + , reaperEmpty = [] + , reaperThreadName = "Reaper" + } -- | State of reaper. -data State workload = NoReaper -- ^ No reaper thread - | Workload !workload -- ^ The current jobs +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 @@ -123,52 +132,71 @@ 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 - , reaperStop = stop stateRef - , reaperKill = kill tidRef - } + 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 + 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) + NoReaper -> (NoReaper, reaperEmpty) Workload x -> (Workload reaperEmpty, x) kill tidRef = do mtid <- readIORef tidRef case mtid of - Nothing -> return () + Nothing -> return () Just tid -> killThread tid -add :: ReaperSettings workload item - -> IORef (State workload) -> IORef (Maybe ThreadId) - -> item -> IO () +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 + 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 ()) + 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 + :: 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 + :: 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. @@ -178,18 +206,22 @@ !merge <- reaperAction wl -- Merging the left jobs and new jobs. -- If there is no jobs, this thread finishes. - next <- atomicModifyIORef' stateRef (check merge) - next + cont <- atomicModifyIORef' stateRef (check merge) + if cont + then + reaper settings stateRef tidRef + else + writeIORef tidRef Nothing where - swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)" + swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)" swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl) - check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)" + check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)" check merge (Workload wl) - -- If there is no job, reaper is terminated. - | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing) - -- If there are jobs, carry them out. - | otherwise = (Workload wl', reaper settings stateRef tidRef) + -- 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 @@ -199,23 +231,37 @@ -- expired. -- -- @since 0.1.1 -mkListAction :: (item -> IO (Maybe item')) - -> [item] - -> IO ([item'] -> [item']) +mkListAction + :: (item -> IO (Maybe item')) + -> [item] + -> IO ([item'] -> [item']) mkListAction f = go id where go !front [] = return front - go !front (x:xs) = do + go !front (x : xs) = do my <- f x let front' = case my of Nothing -> front - Just y -> front . (y:) + 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'). 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/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,5 +1,5 @@ name: auto-update -version: 0.1.6 +version: 0.2.6 synopsis: Efficiently run periodic, on-demand actions description: API docs and the README are available at . homepage: https://github.com/yesodweb/wai @@ -19,8 +19,14 @@ Control.Debounce Control.Debounce.Internal Control.Reaper - other-modules: Control.AutoUpdate.Util - build-depends: base >= 4 && < 5 + 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 @@ -35,4 +41,5 @@ hs-source-dirs: test type: exitcode-stdio-1.0 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,35 +1,37 @@ module Control.AutoUpdateSpec (spec) where -import Control.AutoUpdate -import Control.Concurrent (threadDelay) -import Control.Monad (replicateM_, forM_) -import Data.IORef +-- import Control.AutoUpdate +-- import Control.Concurrent (threadDelay) +-- import Control.Monad (replicateM_, forM_) +-- import Data.IORef import Test.Hspec -import Test.Hspec.QuickCheck +-- import Test.Hspec.QuickCheck + spec :: Spec spec = return () - -- 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 - -- } - -- 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 --- a/test/Control/DebounceSpec.hs +++ b/test/Control/DebounceSpec.hs @@ -1,36 +1,54 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Control.DebounceSpec (spec) where +{-# LANGUAGE NumericUnderscores #-} +module Control.DebounceSpec (main, spec) where -import Control.Concurrent -import Control.Debounce +import Control.Concurrent ( + MVar, + newEmptyMVar, + takeMVar, + putMVar, + newMVar, + threadDelay, + tryReadMVar, + ) +import Control.Debounce ( + DebounceSettings(..), + leadingEdge, + leadingMuteEdge, + trailingEdge, + trailingDelayEdge, + defaultDebounceSettings, + ) import qualified Control.Debounce.Internal as DI -import Control.Monad +import Control.Monad (void) import Control.Monad.Catch -import Control.Retry -import Data.IORef -import Test.HUnit.Lang -import Test.Hspec +import Control.Retry (recovering, constantDelay, limitRetries) +import Data.IORef (IORef, readIORef, newIORef, modifyIORef) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTime) +import Test.Hspec (Spec, describe, it, shouldReturn, hspec) +import Test.HUnit (assertBool) +import Test.HUnit.Lang (HUnitFailure (HUnitFailure)) spec :: Spec spec = describe "mkDebounce" $ do describe "Leading edge" $ do it "works for a single event" $ do - (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge + (ref, debounced, _baton, returnFromWait) <- getDebounce leadingEdge debounced - waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + waitUntil 5 $ readIORef ref `shouldReturn` 1 returnFromWait pause - readIORef ref >>= (`shouldBe` 1) + readIORef ref `shouldReturn` 1 -- Try another round debounced - waitUntil 5 $ readIORef ref >>= (`shouldBe` 2) + waitUntil 5 $ readIORef ref `shouldReturn` 2 returnFromWait pause - readIORef ref >>= (`shouldBe` 2) + readIORef ref `shouldReturn` 2 it "works for multiple events" $ do (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge @@ -39,30 +57,63 @@ waitForBatonToBeTaken baton debounced pause - waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + waitUntil 5 $ readIORef ref `shouldReturn` 1 returnFromWait pause - readIORef ref >>= (`shouldBe` 2) + 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 + (ref, debounced, _baton, returnFromWait) <- getDebounce trailingEdge debounced pause - waitUntil 5 $ readIORef ref >>= (`shouldBe` 0) + readIORef ref `shouldReturn` 0 returnFromWait - waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + waitUntil 5 $ readIORef ref `shouldReturn` 1 -- Try another round debounced pause - waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + waitUntil 5 $ readIORef ref `shouldReturn` 1 returnFromWait - waitUntil 5 $ readIORef ref >>= (`shouldBe` 2) + waitUntil 5 $ readIORef ref `shouldReturn` 2 it "works for multiple events" $ do (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge @@ -71,12 +122,54 @@ waitForBatonToBeTaken baton debounced pause - waitUntil 5 $ readIORef ref >>= (`shouldBe` 0) + readIORef ref `shouldReturn` 0 returnFromWait - waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + 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 @@ -85,36 +178,49 @@ let returnFromWait = putMVar waitVar () return (waitAction, returnFromWait) --- | Get a debounce system with access to the internals for testing getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ()) -getDebounce edge = do - ref :: IORef Int <- newIORef 0 - let action = modifyIORef ref (+ 1) +getDebounce = getDebounce' False - (waitAction, returnFromWait) <- getWaitAction +-- | 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) - baton <- newEmptyMVar + (waitAction, returnFromWait) <- + if useThreadDelay + then pure (threadDelay, pure ()) + else getWaitAction - debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings { - debounceFreq = 5000000 -- unused - , debounceAction = action - , debounceEdge = edge - } + baton <- newMVar () - return (ref, debounced, baton, returnFromWait) + 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 100000 +pause = threadDelay 100_000 waitForBatonToBeTaken :: MVar () -> IO () -waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing) +waitForBatonToBeTaken baton = + waitUntil 5 $ tryReadMVar baton `shouldReturn` Nothing -- | Wait up to n seconds for an action to complete without throwing an HUnitFailure waitUntil :: Int -> IO a -> IO () -waitUntil n action = recovering policy [handler] (\_status -> void action) - where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds - handler _status = Handler (\(HUnitFailure {}) -> return True) +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 --- a/test/Control/ReaperSpec.hs +++ b/test/Control/ReaperSpec.hs @@ -1,14 +1,15 @@ module Control.ReaperSpec (spec) where -import Control.Concurrent -import Control.Reaper -import Data.IORef +-- import Control.Concurrent +-- import Control.Reaper +-- import Data.IORef import Test.Hspec -import Test.Hspec.QuickCheck +-- import Test.Hspec.QuickCheck spec :: Spec spec = return () + -- prop "works" $ \is -> do -- reaper <- mkReaper defaultReaperSettings -- { reaperAction = action