diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,19 @@ +# Changelog + +All notable changes to `auto-update-unliftio` will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org). + +## [Unreleased] + +## [0.1.0] - 26.06.2026 + +### Added + +- `AutoUpdate`, `Debounce` and `Reaper` code adapted from the original [auto-update](https://hackage.haskell.org/package/auto-update) package. +- Test suite copied (and uncommented) from the original package. + +[unreleased]: https://github.com/fpringle/auto-update-unliftio/compare/v0.1.0...HEAD +[0.1.0]: https://github.com/fpringle/auto-update-unliftio/releases/tag/v0.1.0 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026, Frederick Pringle + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Frederick Pringle nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +## auto-update-unliftio + +This is an almost direct clone of yesod's [auto-update](https://hackage.haskell.org/package/auto-update), but generalised to [MonadUnliftIO](https://hackage-content.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#t:MonadUnliftIO). diff --git a/auto-update-unliftio.cabal b/auto-update-unliftio.cabal new file mode 100644 --- /dev/null +++ b/auto-update-unliftio.cabal @@ -0,0 +1,80 @@ +cabal-version: 3.0 +name: auto-update-unliftio +version: 0.1.0 +synopsis: auto-update unlifted to MonadUnliftIO +description: Efficiently run periodic, on-demand actions, in instances of [MonadUnliftIO](https://hackage-content.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#t:MonadUnliftIO) +license: BSD-3-Clause +license-file: LICENSE +author: Frederick Pringle +maintainer: frederick.pringle@fpringle.com +category: Control +copyright: Copyright(c) Frederick Pringle 2026 +homepage: https://github.com/fpringle/auto-update-unliftio +build-type: Simple +extra-doc-files: CHANGELOG.md + README.md + +tested-with: + GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.5 + , GHC == 9.6.1 + , GHC == 9.6.7 + , GHC == 9.8.2 + , GHC == 9.10.2 + , GHC == 9.12.2 + +source-repository head + type: git + location: https://github.com/fpringle/auto-update-unliftio + +common warnings + ghc-options: -Wall -Wno-unused-do-bind + +common deps + build-depends: + , base >= 4 && < 5 + , unliftio >= 0.2.1.0 && < 0.3 + +library + import: + warnings + , deps + exposed-modules: + UnliftIO.AutoUpdate + UnliftIO.AutoUpdate.Internal + UnliftIO.AutoUpdate.Types + UnliftIO.AutoUpdate.Thread + UnliftIO.AutoUpdate.Event + + UnliftIO.Debounce + UnliftIO.Debounce.Internal + + UnliftIO.Reaper + UnliftIO.Reaper.Internal + hs-source-dirs: src + default-language: Haskell2010 + +test-suite auto-update-unliftio-test + import: + warnings + , deps + default-language: Haskell2010 + other-modules: + UnliftIO.AutoUpdateSpec + UnliftIO.DebounceSpec + UnliftIO.ReaperSpec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-tool-depends: + hspec-discover:hspec-discover + ghc-options: -Wno-orphans + build-depends: + , auto-update-unliftio + , exceptions + , hspec + , retry + , HUnit diff --git a/src/UnliftIO/AutoUpdate.hs b/src/UnliftIO/AutoUpdate.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/AutoUpdate.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} + +{- | This is an almost direct copy of [Control.AutoUpdate](https://hackage.haskell.org/package/auto-update/docs/Control-AutoUpdate.html) + from the /auto-update/ package. The salient difference is that this module allows us to define auto-updating actions in arbitrary + monads using 'MonadUnliftIO'. + + 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 'Data.IORef.IORef', than it is for each + request to make its own call to 'Data.Time.Clock.getCurrentTime'. + + But for a low-volume server, whose request frequency is less than once per + second, that approach will result in /more/ calls to 'Data.Time.Clock.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 + be executed by the calling thread. + + Example usage: + + @ + import "Data.Time" + import "Control.AutoUpdate" + + getTime <- 'mkAutoUpdate' 'defaultUpdateSettings' + { 'updateAction' = 'Data.Time.Clock.getCurrentTime' + , 'updateFreq' = 1000000 -- The default frequency, once per second + } + currentTime <- getTime + @ + + For more examples, . +-} +module UnliftIO.AutoUpdate + ( -- * Type + UpdateSettings + , defaultUpdateSettings + + -- * Accessors + , updateAction + , updateFreq + , updateThreadName + + -- * Creation + , mkAutoUpdate + , mkAutoUpdateWithModify + ) +where + +import Control.Monad.IO.Class (liftIO) +import UnliftIO (MonadUnliftIO) +import UnliftIO.AutoUpdate.Types +#ifdef mingw32_HOST_OS +import UnliftIO.AutoUpdate.Thread +#else +import qualified UnliftIO.AutoUpdate.Event as Event +import qualified UnliftIO.AutoUpdate.Thread as Thread + +import GHC.Event + +{- | 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 :: MonadUnliftIO m => UpdateSettings m a -> m (m a) +mkAutoUpdate settings = do + mmgr <- liftIO 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.0 +-} +mkAutoUpdateWithModify :: MonadUnliftIO m => UpdateSettings m a -> (a -> m a) -> m (m a) +mkAutoUpdateWithModify settings f = do + mmgr <- liftIO getSystemEventManager + case mmgr of + Nothing -> Thread.mkAutoUpdateWithModify settings f + Just _m -> Event.mkAutoUpdateWithModify settings f +#endif diff --git a/src/UnliftIO/AutoUpdate/Event.hs b/src/UnliftIO/AutoUpdate/Event.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/AutoUpdate/Event.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} + +module UnliftIO.AutoUpdate.Event + ( -- * Creation + mkAutoUpdate + , mkAutoUpdateWithModify + + -- * Internal + , UpdateState (..) + , mkClosableAutoUpdate + , mkClosableAutoUpdate' + ) +where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) +import UnliftIO (MonadUnliftIO) +import UnliftIO.AutoUpdate.Types +import UnliftIO.IORef +import UnliftIO.STM + +-------------------------------------------------------------------------------- + +{- | 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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m 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.0 +-} +mkAutoUpdateWithModify :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (m a) +mkAutoUpdateWithModify = mkAutoUpdateThingsWithModify (\g _ _ -> g) + +-------------------------------------------------------------------------------- + +data UpdateState m a = UpdateState + { usUpdateAction_ :: a -> m a + , usLastResult_ :: IORef a + , usIntervalMicro_ :: Int + , usTimeHasCome_ :: TVar Bool + , usDeleteTimeout_ :: IORef (m ()) + } + +-------------------------------------------------------------------------------- + +mkAutoUpdateThings :: + (MonadUnliftIO m) => + (m a -> m () -> UpdateState m a -> b) -> + UpdateSettings m a -> + m b +mkAutoUpdateThings mk settings@UpdateSettings {..} = + mkAutoUpdateThingsWithModify mk settings (const updateAction) + +mkAutoUpdateThingsWithModify :: + (MonadUnliftIO m) => + (m a -> m () -> UpdateState m a -> b) -> + UpdateSettings m a -> + (a -> m a) -> + m b +mkAutoUpdateThingsWithModify mk settings update1 = do + us <- openUpdateState settings update1 + pure $ mk (getUpdateResult us) (closeUpdateState us) us + +-------------------------------------------------------------------------------- + +{- $setup + >>> :seti -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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m a, m ()) +mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c) + +-- | provide `UpdateState` for debugging +mkClosableAutoUpdate' :: (MonadUnliftIO m) => UpdateSettings m a -> m (m a, m (), UpdateState m a) +mkClosableAutoUpdate' = mkAutoUpdateThings (,,) + +-------------------------------------------------------------------------------- + +mkDeleteTimeout :: (MonadUnliftIO m) => TVar Bool -> Int -> m (m ()) +mkDeleteTimeout thc micro = do + mgr <- liftIO getSystemTimerManager + key <- liftIO $ registerTimeout mgr micro (atomically $ writeTVar thc True) + pure $ liftIO $ unregisterTimeout mgr key + +openUpdateState :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (UpdateState m a) +openUpdateState UpdateSettings {..} update1 = do + thc <- newTVarIO False + UpdateState update1 + <$> (newIORef =<< updateAction) + <*> pure updateFreq + <*> pure thc + <*> (newIORef =<< mkDeleteTimeout thc updateFreq) + +closeUpdateState :: (MonadUnliftIO m) => UpdateState m a -> m () +closeUpdateState UpdateState {..} = do + join $ readIORef usDeleteTimeout_ + +onceOnTimeHasCome :: (MonadUnliftIO m) => UpdateState m a -> m () -> m () +onceOnTimeHasCome UpdateState {..} action = do + join . atomically $ do + timeHasCome <- readTVar usTimeHasCome_ + when timeHasCome $ writeTVar usTimeHasCome_ False + pure $ when timeHasCome action + +getUpdateResult :: (MonadUnliftIO m) => UpdateState m a -> m a +getUpdateResult us@UpdateState {..} = do + onceOnTimeHasCome us $ do + writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_ + writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ + readIORef usLastResult_ diff --git a/src/UnliftIO/AutoUpdate/Internal.hs b/src/UnliftIO/AutoUpdate/Internal.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/AutoUpdate/Internal.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_HADDOCK not-home #-} + +module UnliftIO.AutoUpdate.Internal + ( -- * Debugging + UpdateState (..) + , mkClosableAutoUpdate + , mkClosableAutoUpdate' + ) +where + +import UnliftIO.AutoUpdate.Event diff --git a/src/UnliftIO/AutoUpdate/Thread.hs b/src/UnliftIO/AutoUpdate/Thread.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/AutoUpdate/Thread.hs @@ -0,0 +1,138 @@ +module UnliftIO.AutoUpdate.Thread + ( -- * Creation + mkAutoUpdate + , mkAutoUpdateWithModify + ) +where + +import Control.Exception (throw) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Maybe (fromMaybe) +import GHC.Conc.Sync (labelThread) +import UnliftIO (MonadUnliftIO) +import UnliftIO.AutoUpdate.Types +import UnliftIO.Concurrent (forkIO, threadDelay) +import UnliftIO.Exception + ( SomeException + , catch + , mask_ + , try + ) +import UnliftIO.IORef (newIORef, readIORef, writeIORef) +import UnliftIO.MVar + ( newEmptyMVar + , putMVar + , readMVar + , takeMVar + , tryPutMVar + ) + +{- | 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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m 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.0 +-} +mkAutoUpdateWithModify :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (m a) +mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f) + +mkAutoUpdateHelper :: (MonadUnliftIO m) => UpdateSettings m a -> Maybe (a -> m a) -> m (m 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 + liftIO . labelThread tid $ updateThreadName us + pure $ 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 -> pure 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 :: (MonadUnliftIO m) => m a -> m a +catchSome act = UnliftIO.Exception.catch act $ \e -> pure $ throw (e :: SomeException) diff --git a/src/UnliftIO/AutoUpdate/Types.hs b/src/UnliftIO/AutoUpdate/Types.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/AutoUpdate/Types.hs @@ -0,0 +1,48 @@ +module UnliftIO.AutoUpdate.Types where + +import Data.Functor.Identity + +{- | 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 m a = UpdateSettings + { updateFreq :: Int + -- ^ Microseconds between update calls. Same considerations as + -- 'Control.Concurrent.threadDelay' apply. + -- + -- Default: 1000000 microseconds (1 second) + -- + -- @since 0.1.0 + , updateAction :: m 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.1.0 + } + +{- | Default value for creating an 'UpdateSettings'. + + @since 0.1.0 +-} +defaultUpdateSettings :: UpdateSettings Identity () +defaultUpdateSettings = + UpdateSettings + { updateFreq = 1000000 + , updateAction = pure () + , updateThreadName = "AutoUpdate" + } diff --git a/src/UnliftIO/Debounce.hs b/src/UnliftIO/Debounce.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Debounce.hs @@ -0,0 +1,81 @@ +{- | This is an almost direct copy of [Control.Debounce](https://hackage.haskell.org/package/auto-update/docs/Control-Debounce.html) + from the /auto-update/ package. The salient difference is that this module allows us to debounce actions in arbitrary + monads using 'MonadUnliftIO'. + + 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' 'DI.defaultDebounceSettings' + { 'DI.debounceAction' = putStrLn "Running action" + , 'DI.debounceFreq' = 5000000 -- 5 seconds + , 'DI.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.0 +-} +module UnliftIO.Debounce + ( -- * Creation + mkDebounce + + -- * Settings + , DI.DebounceSettings + , defaultDebounceSettings + + -- ** Accessors + , DI.debounceFreq + , DI.debounceAction + , DI.debounceEdge + , DI.debounceThreadName + + -- ** Edge types + , DI.DebounceEdge + , DI.leadingEdge + , DI.leadingMuteEdge + , DI.trailingEdge + , DI.trailingDelayEdge + ) +where + +import Data.Functor.Identity +import UnliftIO (MonadUnliftIO) +import UnliftIO.Concurrent (newMVar, threadDelay) +import qualified UnliftIO.Debounce.Internal as DI + +{- | Default value for creating a 'DI.DebounceSettings'. + + @since 0.1.0 +-} +defaultDebounceSettings :: DI.DebounceSettings Identity +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 'DI.debounceFreq',/ + /as the debounced action (and the delay\/cooldown) is always performed in a separate thread./ + + @since 0.1.0 +-} +mkDebounce :: (MonadUnliftIO m) => DI.DebounceSettings m -> m (m ()) +mkDebounce settings = do + baton <- newMVar () + DI.mkDebounceInternal baton threadDelay settings diff --git a/src/UnliftIO/Debounce/Internal.hs b/src/UnliftIO/Debounce/Internal.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Debounce/Internal.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Unstable API which exposes internals for testing. +module UnliftIO.Debounce.Internal + ( DebounceSettings (..) + , DebounceEdge (..) + , leadingEdge + , leadingMuteEdge + , trailingEdge + , trailingDelayEdge + , mkDebounceInternal + ) +where + +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Conc.Sync (labelThread) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Exception (SomeException, handle, mask_) +import UnliftIO.MVar + ( MVar + , newEmptyMVar + , putMVar + , tryPutMVar + , tryTakeMVar + ) +import UnliftIO.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) + +{- | Settings to control how debouncing should work. + + This should be constructed using 'UnliftIO.Debounce.defaultDebounceSettings' and record + update syntax, e.g.: + + @ + let settings = 'UnliftIO.Debounce.defaultDebounceSettings' { 'debounceAction' = flushLog } + @ + + @since 0.1.0 +-} +data DebounceSettings m = DebounceSettings + { debounceFreq :: Int + -- ^ Length of the debounce timeout period in microseconds. + -- + -- Default: 1 second (1000000) + -- + -- @since 0.1.0 + , debounceAction :: m () + -- ^ Action to be performed. + -- + -- Note: all exceptions thrown by this action will be silently discarded. + -- + -- Default: does nothing. + -- + -- @since 0.1.0 + , debounceEdge :: DebounceEdge + -- ^ Whether to perform the action on the leading edge or trailing edge of + -- the timeout. + -- + -- Default: 'leadingEdge'. + -- + -- @since 0.1.0 + , debounceThreadName :: String + -- ^ Label of the thread spawned when debouncing. + -- + -- Default: @"Debounce"@. + -- + -- @since 0.1.0 + } + +{- | Setting to control whether the action happens at the leading and/or trailing + edge of the timeout. + + @since 0.1.0 +-} +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.0 +-} +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.0 +-} +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.0 +-} +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.0 +-} +trailingDelayEdge :: DebounceEdge +trailingDelayEdge = TrailingDelay + +mkDebounceInternal :: + forall m. + (MonadUnliftIO m) => + MVar () -> + (Int -> m ()) -> + DebounceSettings m -> + m (m ()) +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 <- liftIO 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 <- liftIO getMonotonicTimeNSec + -- 5) + let diff = fromIntegral (now - lastTrigger) `div` 1000 + shouldWait = diff < freq + if shouldWait + then -- 6) + loop $ freq - diff + else do + ignoreExc action + timeAfterAction <- readTVarIO timeTVar + -- 7) + let wasTriggered = timeAfterAction > now + if wasTriggered + then do + updatedNow <- liftIO getMonotonicTimeNSec + let newDiff = fromIntegral (updatedNow - timeAfterAction) `div` 1000 + loop $ freq - newDiff + else -- 8) + putMVar baton () + + forkAndLabel act = do + tid <- mask_ $ forkIO act + liftIO $ labelThread tid name + +ignoreExc :: (MonadUnliftIO m) => m () -> m () +ignoreExc = handle $ \(_ :: SomeException) -> pure () diff --git a/src/UnliftIO/Reaper.hs b/src/UnliftIO/Reaper.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Reaper.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +{- | This is an almost direct copy of [Control.Reaper](https://hackage.haskell.org/package/auto-update/docs/Control-Reaper.html) + from the /auto-update/ package. The salient difference is that this module allows us to define cleanup threads in arbitrary + monads using 'MonadUnliftIO'. + + 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 UnliftIO.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.Monad (forM_, join) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Functor.Identity +import GHC.Conc.Sync (labelThread) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Concurrent (ThreadId, forkIO, killThread, threadDelay) +import UnliftIO.Exception (mask_) +import UnliftIO.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import UnliftIO.Reaper.Internal + +{- | 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.0 +-} +data ReaperSettings m workload item = ReaperSettings + { reaperAction :: workload -> m (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.0 + , reaperDelay :: {-# UNPACK #-} !Int + -- ^ Number of microseconds to delay between calls of 'reaperAction'. + -- + -- Default: 30 seconds. + -- + -- @since 0.1.0 + , reaperCons :: item -> workload -> workload + -- ^ Add an item onto a workload. + -- + -- Default: list consing. + -- + -- @since 0.1.0 + , reaperNull :: workload -> Bool + -- ^ Check if a workload is empty, in which case the worker thread + -- will shut down. + -- + -- Default: 'null'. + -- + -- @since 0.1.0 + , reaperEmpty :: workload + -- ^ An empty workload. + -- + -- Default: empty list. + -- + -- @since 0.1.0 + , reaperThreadName :: String + -- ^ Label of the thread spawned by the reaper. + -- + -- Default: @"Reaper"@. + -- + -- @since 0.1.0 + } + +{- | Default @ReaperSettings@ value, biased towards having a list of work + items. + + @since 0.1.0 +-} +defaultReaperSettings :: ReaperSettings Identity [item] item +defaultReaperSettings = + ReaperSettings + { reaperAction = \wl -> pure (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.0 +-} +mkReaper :: (MonadUnliftIO m) => ReaperSettings m workload item -> m (Reaper m 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 $ \case + NoReaper -> + (NoReaper, reaperEmpty) + Workload wl -> + let !wl' = modifier wl + in (Workload wl', wl') + stop stateRef = atomicModifyIORef' stateRef $ \case + NoReaper -> (NoReaper, reaperEmpty) + Workload x -> (Workload reaperEmpty, x) + kill tidRef = do + mtid <- readIORef tidRef + forM_ mtid killThread + +add :: + (MonadUnliftIO m) => + ReaperSettings m workload item -> + IORef (State workload) -> + IORef (Maybe ThreadId) -> + item -> + m () +add settings@ReaperSettings {..} stateRef tidRef item = + mask_ $ join $ atomicModifyIORef' stateRef cons + 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 :: + (MonadUnliftIO m) => + ReaperSettings m workload item -> + IORef (State workload) -> + IORef (Maybe ThreadId) -> + m () +spawn settings stateRef tidRef = do + tid <- forkIO $ reaper settings stateRef tidRef + liftIO . labelThread tid $ reaperThreadName settings + writeIORef tidRef $ Just tid + +reaper :: + (MonadUnliftIO m) => + ReaperSettings m workload item -> + IORef (State workload) -> + IORef (Maybe ThreadId) -> + m () +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.0 +-} +mkListAction :: + (Monad m) => + (item -> m (Maybe item')) -> + [item] -> + m ([item'] -> [item']) +mkListAction f = + go id + where + go !front [] = pure 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/src/UnliftIO/Reaper/Internal.hs b/src/UnliftIO/Reaper/Internal.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Reaper/Internal.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_HADDOCK not-home #-} + +module UnliftIO.Reaper.Internal (Reaper (..)) where + +-- | A data structure to hold reaper APIs. +data Reaper m workload item = Reaper + { reaperAdd :: item -> m () + -- ^ Adding an item to the workload + , reaperRead :: m workload + -- ^ Reading workload. + , reaperModify :: (workload -> workload) -> m workload + -- ^ Modify the workload. The resulting workload is returned. + -- + -- If there is no reaper thread, the modifier will not be applied and + -- 'UnliftIO.Reaper.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 'UnliftIO.Reaper.reaperAction' satisfies 'UnliftIO.Reaper.reaperNull'. + -- + -- @since 0.1.0 + , reaperStop :: m workload + -- ^ Stopping the reaper thread if exists. + -- The current workload is returned. + , reaperKill :: m () + -- ^ Killing the reaper thread immediately if exists. + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UnliftIO/AutoUpdateSpec.hs b/test/UnliftIO/AutoUpdateSpec.hs new file mode 100644 --- /dev/null +++ b/test/UnliftIO/AutoUpdateSpec.hs @@ -0,0 +1,36 @@ +module UnliftIO.AutoUpdateSpec (spec) where + +-- import UnliftIO.AutoUpdate +-- import Control.Concurrent (threadDelay) +-- import Control.Monad (replicateM_, forM_) +-- import Data.IORef +import Test.Hspec + +-- 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') +-- , updateFreq = 10000 +-- } + +-- forM_ [1..st + 1] $ \i -> do +-- j <- next +-- j `shouldBe` i + +-- 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/UnliftIO/DebounceSpec.hs b/test/UnliftIO/DebounceSpec.hs new file mode 100644 --- /dev/null +++ b/test/UnliftIO/DebounceSpec.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE NumericUnderscores #-} + +module UnliftIO.DebounceSpec (main, spec) where + +import Control.Concurrent + ( MVar + , newEmptyMVar + , newMVar + , putMVar + , takeMVar + , threadDelay + , tryReadMVar + ) +import Control.Monad (void) +import Control.Monad.Catch +import Control.Retry (constantDelay, limitRetries, recovering) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import GHC.Clock (getMonotonicTime) +import Test.HUnit (assertBool) +import Test.HUnit.Lang (HUnitFailure (HUnitFailure)) +import Test.Hspec (Spec, describe, hspec, it, shouldReturn) +import UnliftIO.Debounce + ( DebounceSettings (..) + , defaultDebounceSettings + , leadingEdge + , leadingMuteEdge + , trailingDelayEdge + , trailingEdge + ) +import qualified UnliftIO.Debounce.Internal as DI + +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/UnliftIO/ReaperSpec.hs b/test/UnliftIO/ReaperSpec.hs new file mode 100644 --- /dev/null +++ b/test/UnliftIO/ReaperSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module UnliftIO.ReaperSpec (spec) where + +import Control.Concurrent +import Data.IORef +import Test.Hspec +import Test.Hspec.QuickCheck +import UnliftIO.Reaper + +spec :: Spec +spec = do + prop "works" $ \(is :: [Int]) -> 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 :: [Item] -> IO ([Item] -> [Item]) +action = mkListAction $ \(i, ref) -> do + modifyIORef ref succ + return $ + if i > 1 + then Just (pred i, ref) + else Nothing