diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # ChangeLog for auto-update +## 0.1.6 + +* Add control of activation on leading vs. trailing edges for Control.Debounce + [#756](https://github.com/yesodweb/wai/pull/756) + ## 0.1.5 * Using the Strict and StrictData language extensions for GHC >8. diff --git a/Control/Debounce.hs b/Control/Debounce.hs --- a/Control/Debounce.hs +++ b/Control/Debounce.hs @@ -11,6 +11,7 @@ -- printString <- 'mkDebounce' 'defaultDebounceSettings' -- { 'debounceAction' = putStrLn "Running action" -- , 'debounceFreq' = 5000000 -- 5 seconds +-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge -- } -- @ -- @@ -25,70 +26,35 @@ -- @since 0.1.2 module Control.Debounce ( -- * Type - DebounceSettings + DI.DebounceSettings , defaultDebounceSettings -- * Accessors - , debounceFreq - , debounceAction + , DI.debounceFreq + , DI.debounceAction + , DI.debounceEdge + , DI.leadingEdge + , DI.trailingEdge -- * Creation , mkDebounce ) where -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) -import Control.Exception (SomeException, handle, mask_) -import Control.Monad (forever, void) - --- | Settings to control how debouncing should work. --- --- This should be constructed using 'defaultDebounceSettings' and record --- update syntax, e.g.: --- --- @ --- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog } --- @ --- --- @since 0.1.2 -data DebounceSettings = DebounceSettings - { debounceFreq :: Int - -- ^ Microseconds lag required between subsequence calls to the debounced - -- action. - -- - -- Default: 1 second (1000000) - -- - -- @since 0.1.2 - , debounceAction :: IO () - -- ^ Action to be performed. - -- - -- Note: all exceptions thrown by this action will be silently discarded. - -- - -- Default: does nothing. - -- - -- @since 0.1.2 - } +import Control.Concurrent (newEmptyMVar, threadDelay) +import qualified Control.Debounce.Internal as DI -- | Default value for creating a 'DebounceSettings'. -- -- @since 0.1.2 -defaultDebounceSettings :: DebounceSettings -defaultDebounceSettings = DebounceSettings - { debounceFreq = 1000000 - , debounceAction = return () +defaultDebounceSettings :: DI.DebounceSettings +defaultDebounceSettings = DI.DebounceSettings + { DI.debounceFreq = 1000000 + , DI.debounceAction = return () + , DI.debounceEdge = DI.leadingEdge } --- | Generate an action which will trigger the debounced action to be --- performed. The action will either be performed immediately, or after the --- current cooldown period has expired. +-- | Generate an action which will trigger the debounced action to be performed. -- -- @since 0.1.2 -mkDebounce :: DebounceSettings -> IO (IO ()) -mkDebounce (DebounceSettings freq action) = do - baton <- newEmptyMVar - mask_ $ void $ forkIO $ forever $ do - takeMVar baton - ignoreExc action - threadDelay freq - return $ void $ tryPutMVar baton () - -ignoreExc :: IO () -> IO () -ignoreExc = handle $ \(_ :: SomeException) -> return () +mkDebounce :: DI.DebounceSettings -> IO (IO ()) +mkDebounce settings = do + baton <- newEmptyMVar + DI.mkDebounceInternal baton threadDelay settings diff --git a/Control/Debounce/Internal.hs b/Control/Debounce/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/Debounce/Internal.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Unstable API which exposes internals for testing. +module Control.Debounce.Internal ( + DebounceSettings(..) + , DebounceEdge(..) + , leadingEdge + , trailingEdge + , 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) + +-- | Settings to control how debouncing should work. +-- +-- This should be constructed using 'defaultDebounceSettings' and record +-- update syntax, e.g.: +-- +-- @ +-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog } +-- @ +-- +-- @since 0.1.2 +data DebounceSettings = DebounceSettings + { debounceFreq :: Int + -- ^ Length of the debounce timeout period in microseconds. + -- + -- Default: 1 second (1000000) + -- + -- @since 0.1.2 + , debounceAction :: IO () + -- ^ Action to be performed. + -- + -- Note: all exceptions thrown by this action will be silently discarded. + -- + -- Default: does nothing. + -- + -- @since 0.1.2 + , debounceEdge :: DebounceEdge + -- ^ Whether to perform the action on the leading edge or trailing edge of + -- the timeout. + -- + -- Default: 'trailingEdge'. + -- + -- @since 0.1.6 + } + +-- | 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) + + +-- | 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. +-- +-- @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. +-- +-- @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 + ignoreExc action + delayFn freq + Trailing -> do + delayFn freq + -- Empty the baton of any other activations during the interval + void $ tryTakeMVar baton + ignoreExc action + + return $ void $ tryPutMVar baton () + +ignoreExc :: IO () -> IO () +ignoreExc = handle $ \(_ :: SomeException) -> return () 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.5 +version: 0.1.6 synopsis: Efficiently run periodic, on-demand actions description: API docs and the README are available at . homepage: https://github.com/yesodweb/wai @@ -17,6 +17,7 @@ ghc-options: -Wall exposed-modules: Control.AutoUpdate Control.Debounce + Control.Debounce.Internal Control.Reaper other-modules: Control.AutoUpdate.Util build-depends: base >= 4 && < 5 @@ -26,11 +27,12 @@ -- Test suite is currently not robust enough, gives too many false negatives. --- test-suite spec --- main-is: Spec.hs --- other-modules: Control.AutoUpdateSpec --- Control.ReaperSpec --- hs-source-dirs: test --- type: exitcode-stdio-1.0 --- build-depends: base, auto-update, hspec --- default-language: Haskell2010 +test-suite spec + main-is: Spec.hs + other-modules: Control.AutoUpdateSpec + Control.DebounceSpec + Control.ReaperSpec + hs-source-dirs: test + type: exitcode-stdio-1.0 + build-depends: base, auto-update, exceptions, hspec, retry, HUnit + default-language: Haskell2010 diff --git a/test/Control/AutoUpdateSpec.hs b/test/Control/AutoUpdateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/AutoUpdateSpec.hs @@ -0,0 +1,35 @@ +module Control.AutoUpdateSpec (spec) where + +import Control.AutoUpdate +import Control.Concurrent (threadDelay) +import Control.Monad (replicateM_, forM_) +import Data.IORef +import Test.Hspec +import Test.Hspec.QuickCheck + +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 + + -- replicateM_ 50 $ do + -- i <- next + -- i `shouldBe` st + 2 + + -- threadDelay 60000 + -- last1 <- readIORef ref + -- threadDelay 20000 + -- last2 <- readIORef ref + -- last2 `shouldBe` last1 diff --git a/test/Control/DebounceSpec.hs b/test/Control/DebounceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/DebounceSpec.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Control.DebounceSpec (spec) where + +import Control.Concurrent +import Control.Debounce +import qualified Control.Debounce.Internal as DI +import Control.Monad +import Control.Monad.Catch +import Control.Retry +import Data.IORef +import Test.HUnit.Lang +import Test.Hspec + +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 >>= (`shouldBe` 1) + + returnFromWait + pause + readIORef ref >>= (`shouldBe` 1) + + -- Try another round + debounced + waitUntil 5 $ readIORef ref >>= (`shouldBe` 2) + + returnFromWait + pause + readIORef ref >>= (`shouldBe` 2) + + it "works for multiple events" $ do + (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge + + debounced + waitForBatonToBeTaken baton + debounced + pause + waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + + returnFromWait + pause + readIORef ref >>= (`shouldBe` 2) + + describe "Trailing edge" $ do + it "works for a single event" $ do + (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge + + debounced + pause + waitUntil 5 $ readIORef ref >>= (`shouldBe` 0) + + returnFromWait + waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + + -- Try another round + debounced + pause + waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + + returnFromWait + waitUntil 5 $ readIORef ref >>= (`shouldBe` 2) + + it "works for multiple events" $ do + (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge + + debounced + waitForBatonToBeTaken baton + debounced + pause + waitUntil 5 $ readIORef ref >>= (`shouldBe` 0) + + returnFromWait + waitUntil 5 $ readIORef ref >>= (`shouldBe` 1) + + +-- | 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) + +-- | 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) + + (waitAction, returnFromWait) <- getWaitAction + + baton <- newEmptyMVar + + debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings { + debounceFreq = 5000000 -- unused + , debounceAction = action + , debounceEdge = edge + } + + return (ref, debounced, baton, returnFromWait) + +-- | Pause briefly (100ms) +pause :: IO () +pause = threadDelay 100000 + +waitForBatonToBeTaken :: MVar () -> IO () +waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing) + +-- | Wait up to n seconds for an action to complete without throwing an HUnitFailure +waitUntil :: Int -> IO a -> IO () +waitUntil n action = recovering policy [handler] (\_status -> void action) + where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds + handler _status = Handler (\(HUnitFailure {}) -> return True) + +main :: IO () +main = hspec spec diff --git a/test/Control/ReaperSpec.hs b/test/Control/ReaperSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/ReaperSpec.hs @@ -0,0 +1,39 @@ +module Control.ReaperSpec (spec) where + +import Control.Concurrent +import Control.Reaper +import Data.IORef +import Test.Hspec +import Test.Hspec.QuickCheck + + +spec :: Spec +spec = return () +-- prop "works" $ \is -> do +-- reaper <- mkReaper defaultReaperSettings +-- { reaperAction = action +-- , reaperDelay = 1000 +-- } + +-- let mkTestCase i = do +-- ref <- newIORef 0 +-- let expected = (abs i `mod` 10) + 1 +-- reaperAdd reaper (expected, ref) +-- return (expected, ref) +-- testCases <- mapM mkTestCase is + +-- let test (expected, ref) = do +-- actual <- readIORef ref +-- actual `shouldBe` (expected :: Int) +-- threadDelay 100000 +-- mapM_ test testCases +-- [] <- reaperRead reaper +-- return () + +-- type Item = (Int, IORef Int) + +-- action = mkListAction $ \(i, ref) -> do +-- modifyIORef ref succ +-- return $ if i > 1 +-- then Just (pred i, ref) +-- else Nothing 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 #-}