Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-auto-update for openSUSE:Factory
checked in at 2024-11-12 19:20:12
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-auto-update (Old)
and /work/SRC/openSUSE:Factory/.ghc-auto-update.new.2017 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-auto-update"
Tue Nov 12 19:20:12 2024 rev:19 rq:1222953 version:0.2.2
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-auto-update/ghc-auto-update.changes
2023-04-04 21:18:35.040487905 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-auto-update.new.2017/ghc-auto-update.changes
2024-11-12 19:20:37.345459271 +0100
@@ -1,0 +2,22 @@
+Tue Oct 29 05:50:49 UTC 2024 - Peter Simons <[email protected]>
+
+- Update auto-update to version 0.2.2.
+ ## 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.
+ * Add `reaperModify` to the `Reaper` API, allowing workload modification
outside
+ of the main `reaperAction` loop.
+ [#985](https://github.com/yesodweb/wai/pull/985)
+
+-------------------------------------------------------------------
Old:
----
auto-update-0.1.6.tar.gz
New:
----
auto-update-0.2.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-auto-update.spec ++++++
--- /var/tmp/diff_new_pack.pquns2/_old 2024-11-12 19:20:38.309499662 +0100
+++ /var/tmp/diff_new_pack.pquns2/_new 2024-11-12 19:20:38.309499662 +0100
@@ -1,7 +1,7 @@
#
# spec file for package ghc-auto-update
#
-# Copyright (c) 2023 SUSE LLC
+# Copyright (c) 2024 SUSE LLC
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -20,7 +20,7 @@
%global pkgver %{pkg_name}-%{version}
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.1.6
+Version: 0.2.2
Release: 0
Summary: Efficiently run periodic, on-demand actions
License: MIT
++++++ auto-update-0.1.6.tar.gz -> auto-update-0.2.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/ChangeLog.md
new/auto-update-0.2.2/ChangeLog.md
--- old/auto-update-0.1.6/ChangeLog.md 2019-07-09 09:40:38.000000000 +0200
+++ new/auto-update-0.2.2/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200
@@ -1,5 +1,23 @@
# ChangeLog for auto-update
+## 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.
+* Add `reaperModify` to the `Reaper` API, allowing workload modification
outside
+ of the main `reaperAction` loop.
+ [#985](https://github.com/yesodweb/wai/pull/985)
+
## 0.1.6
* Add control of activation on leading vs. trailing edges for Control.Debounce
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/AutoUpdate/Util.hs
new/auto-update-0.2.2/Control/AutoUpdate/Util.hs
--- old/auto-update-0.1.6/Control/AutoUpdate/Util.hs 2015-11-09
03:12:10.000000000 +0100
+++ new/auto-update-0.2.2/Control/AutoUpdate/Util.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,7 +1,8 @@
{-# LANGUAGE CPP #-}
-module Control.AutoUpdate.Util
- ( atomicModifyIORef'
- ) where
+
+module Control.AutoUpdate.Util (
+ atomicModifyIORef',
+) where
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/AutoUpdate.hs
new/auto-update-0.2.2/Control/AutoUpdate.hs
--- old/auto-update-0.1.6/Control/AutoUpdate.hs 2017-06-01 14:48:32.000000000
+0200
+++ new/auto-update-0.2.2/Control/AutoUpdate.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+
-- | In a multithreaded environment, running actions on a regularly scheduled
-- background thread can dramatically improve performance.
-- For example, web servers need to return the current time with each HTTP
response.
@@ -6,12 +7,12 @@
-- 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,38 +30,55 @@
--
-- For more examples,
<http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post
introducing this library>.
module Control.AutoUpdate (
- -- * Type
- UpdateSettings
- , defaultUpdateSettings
- -- * Accessors
- , updateAction
- , updateFreq
- , updateSpawnThreshold
- -- * Creation
- , mkAutoUpdate
- , mkAutoUpdateWithModify
- ) where
+ -- * Type
+ UpdateSettings,
+ defaultUpdateSettings,
+
+ -- * Accessors
+ updateAction,
+ updateFreq,
+ updateSpawnThreshold,
+ updateThreadName,
+
+ -- * Creation
+ mkAutoUpdate,
+ mkAutoUpdateWithModify,
+) where
#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)
+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)
-- | Default value for creating an 'UpdateSettings'.
--
-- @since 0.1.0
defaultUpdateSettings :: UpdateSettings ()
-defaultUpdateSettings = UpdateSettings
- { updateFreq = 1000000
- , updateSpawnThreshold = 3
- , updateAction = return ()
- }
+defaultUpdateSettings =
+ UpdateSettings
+ { updateFreq = 1000000
+ , updateSpawnThreshold = 3
+ , updateAction = return ()
+ , updateThreadName = "AutoUpdate"
+ }
-- | Settings to control how values are updated.
--
@@ -73,7 +91,7 @@
--
-- @since 0.1.0
data UpdateSettings a = UpdateSettings
- { updateFreq :: Int
+ { updateFreq :: Int
-- ^ Microseconds between update calls. Same considerations as
-- 'threadDelay' apply.
--
@@ -90,12 +108,13 @@
-- Default: 3
--
-- @since 0.1.0
- , updateAction :: IO a
+ , updateAction :: IO a
-- ^ Action to be performed to get the current value.
--
-- Default: does nothing.
--
-- @since 0.1.0
+ , updateThreadName :: String
}
-- | Generate an action which will either read from an automatically
@@ -136,12 +155,16 @@
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"
+ 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
@@ -153,7 +176,7 @@
-- 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
+ 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.
@@ -162,7 +185,7 @@
takeMVar needsRunning
-- new value requested, so run the updateAction
- a <- catchSome $ maybe (updateAction us) id
(updateActionModify <*> maybea)
+ a <- catchSome $ fromMaybe (updateAction us)
(updateActionModify <*> maybea)
-- we got a new value, update currRef and lastValue
writeIORef currRef $ Right a
@@ -181,7 +204,7 @@
-- Kick off the loop, with the initial responseVar0 variable.
loop responseVar0 Nothing
-
+ labelThread tid $ updateThreadName us
return $ do
mval <- readIORef currRef
case mval of
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/Debounce/Internal.hs
new/auto-update-0.2.2/Control/Debounce/Internal.hs
--- old/auto-update-0.1.6/Control/Debounce/Internal.hs 2019-07-09
09:40:38.000000000 +0200
+++ new/auto-update-0.2.2/Control/Debounce/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -2,17 +2,23 @@
-- | 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)
+ DebounceSettings (..),
+ DebounceEdge (..),
+ leadingEdge,
+ trailingEdge,
+ mkDebounceInternal,
+) where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (
+ MVar,
+ takeMVar,
+ tryPutMVar,
+ tryTakeMVar,
+ )
+import Control.Exception (SomeException, handle, mask_)
+import Control.Monad (forever, void)
+import GHC.Conc.Sync (labelThread)
-- | Settings to control how debouncing should work.
--
@@ -25,7 +31,7 @@
--
-- @since 0.1.2
data DebounceSettings = DebounceSettings
- { debounceFreq :: Int
+ { debounceFreq :: Int
-- ^ Length of the debounce timeout period in microseconds.
--
-- Default: 1 second (1000000)
@@ -46,22 +52,22 @@
-- Default: 'trailingEdge'.
--
-- @since 0.1.6
+ , debounceThreadName :: String
}
-- | 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
+ | -- | Start a cooldown period and perform the action when the period
ends. If another trigger
+ -- happens during the cooldown, it has no effect.
+ Trailing
+ 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
@@ -78,20 +84,21 @@
trailingEdge :: DebounceEdge
trailingEdge = Trailing
-mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO
())
-mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do
- mask_ $ void $ forkIO $ forever $ do
+mkDebounceInternal
+ :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
+mkDebounceInternal baton delayFn (DebounceSettings freq action edge name) = do
+ tid <- mask_ $ 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
-
+ 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
+ labelThread tid name
return $ void $ tryPutMVar baton ()
ignoreExc :: IO () -> IO ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/Debounce.hs
new/auto-update-0.2.2/Control/Debounce.hs
--- old/auto-update-0.1.6/Control/Debounce.hs 2019-07-09 09:40:38.000000000
+0200
+++ new/auto-update-0.2.2/Control/Debounce.hs 2001-09-09 03:46:40.000000000
+0200
@@ -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,57 @@
-- 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
--- <Wait five seconds>
+-- > printString
+-- \<Wait five seconds>
-- Running action
+-- @
--
-- See the fast-logger package ("System.Log.FastLogger") for real-world usage.
--
-- @since 0.1.2
-module Control.Debounce
- ( -- * Type
- DI.DebounceSettings
- , defaultDebounceSettings
- -- * Accessors
- , DI.debounceFreq
- , DI.debounceAction
- , DI.debounceEdge
- , DI.leadingEdge
- , DI.trailingEdge
- -- * Creation
- , mkDebounce
- ) where
+module Control.Debounce (
+ -- * Type
+ DI.DebounceSettings,
+ defaultDebounceSettings,
+
+ -- * Accessors
+ DI.debounceFreq,
+ DI.debounceAction,
+ DI.debounceEdge,
+ DI.debounceThreadName,
+ DI.leadingEdge,
+ DI.trailingEdge,
+
+ -- * Creation
+ mkDebounce,
+) where
-import Control.Concurrent (newEmptyMVar, threadDelay)
+import Control.Concurrent (newEmptyMVar, 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.
--
-- @since 0.1.2
mkDebounce :: DI.DebounceSettings -> IO (IO ())
mkDebounce settings = do
- baton <- newEmptyMVar
- DI.mkDebounceInternal baton threadDelay settings
+ baton <- newEmptyMVar
+ DI.mkDebounceInternal baton threadDelay settings
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/Reaper/Internal.hs
new/auto-update-0.2.2/Control/Reaper/Internal.hs
--- old/auto-update-0.1.6/Control/Reaper/Internal.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/auto-update-0.2.2/Control/Reaper/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Control/Reaper.hs
new/auto-update-0.2.2/Control/Reaper.hs
--- old/auto-update-0.1.6/Control/Reaper.hs 2019-02-20 10:43:14.000000000
+0100
+++ new/auto-update-0.2.2/Control/Reaper.hs 2001-09-09 03:46:40.000000000
+0200
@@ -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,42 @@
-- For real-world usage, search the <https://github.com/yesodweb/wai WAI
family of packages>
-- for imports of "Control.Reaper".
module Control.Reaper (
- -- * Example: Regularly cleaning a cache
- -- $example1
+ -- * 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,
+
+ -- * Accessors
+ reaperAction,
+ reaperDelay,
+ reaperCons,
+ reaperNull,
+ reaperEmpty,
+ reaperThreadName,
+
+ -- * Type
+ Reaper,
+ reaperAdd,
+ reaperRead,
+ reaperModify,
+ reaperStop,
+ reaperKill,
+
+ -- * Creation
+ mkReaper,
+
+ -- * Helper
+ mkListAction,
+) where
import Control.AutoUpdate.Util (atomicModifyIORef')
-import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
+import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Exception (mask_)
+import Control.Reaper.Internal
import Data.IORef (IORef, 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 +95,7 @@
-- Default: empty list.
--
-- @since 0.1.1
+ , reaperThreadName :: String
}
-- | Default @ReaperSettings@ value, biased towards having a list of work
@@ -90,30 +103,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 +128,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 ())
-
-spawn :: ReaperSettings workload item
- -> IORef (State workload) -> IORef (Maybe ThreadId)
- -> IO ()
+ cons NoReaper =
+ let wl = reaperCons item reaperEmpty
+ in (Workload wl, spawn settings stateRef tidRef)
+ cons (Workload wl) =
+ let wl' = reaperCons item wl
+ in (Workload wl', return ())
+
+spawn
+ :: ReaperSettings workload item
+ -> IORef (State workload)
+ -> IORef (Maybe ThreadId)
+ -> IO ()
spawn settings stateRef tidRef = do
tid <- forkIO $ reaper settings stateRef tidRef
+ labelThread tid $ reaperThreadName settings
writeIORef tidRef $ Just tid
-reaper :: ReaperSettings workload item
- -> IORef (State workload) -> IORef (Maybe ThreadId)
- -> IO ()
+reaper
+ :: 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.
@@ -181,15 +205,15 @@
next <- atomicModifyIORef' stateRef (check merge)
next
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, writeIORef tidRef Nothing)
+ -- If there are jobs, carry them out.
+ | otherwise = (Workload wl', reaper settings stateRef tidRef)
where
wl' = merge wl
@@ -199,24 +223,38 @@
-- 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').
-- The reaper will run every two seconds ('reaperDelay'), but will stop
running while
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/Setup.hs
new/auto-update-0.2.2/Setup.hs
--- old/auto-update-0.1.6/Setup.hs 2015-11-09 03:12:10.000000000 +0100
+++ new/auto-update-0.2.2/Setup.hs 2001-09-09 03:46:40.000000000 +0200
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/auto-update.cabal
new/auto-update-0.2.2/auto-update.cabal
--- old/auto-update-0.1.6/auto-update.cabal 2019-07-09 09:40:38.000000000
+0200
+++ new/auto-update-0.2.2/auto-update.cabal 2001-09-09 03:46:40.000000000
+0200
@@ -1,5 +1,5 @@
name: auto-update
-version: 0.1.6
+version: 0.2.2
synopsis: Efficiently run periodic, on-demand actions
description: API docs and the README are available at
<http://www.stackage.org/package/auto-update>.
homepage: https://github.com/yesodweb/wai
@@ -19,8 +19,9 @@
Control.Debounce
Control.Debounce.Internal
Control.Reaper
+ Control.Reaper.Internal
other-modules: Control.AutoUpdate.Util
- build-depends: base >= 4 && < 5
+ build-depends: base >= 4.12 && < 5
default-language: Haskell2010
if impl(ghc >= 8)
default-extensions: Strict StrictData
@@ -35,4 +36,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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/test/Control/AutoUpdateSpec.hs
new/auto-update-0.2.2/test/Control/AutoUpdateSpec.hs
--- old/auto-update-0.1.6/test/Control/AutoUpdateSpec.hs 2019-07-09
09:40:38.000000000 +0200
+++ new/auto-update-0.2.2/test/Control/AutoUpdateSpec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
-
- -- replicateM_ 50 $ do
- -- i <- next
- -- i `shouldBe` st + 2
-
- -- threadDelay 60000
- -- last1 <- readIORef ref
- -- threadDelay 20000
- -- last2 <- readIORef ref
- -- last2 `shouldBe` last1
+
+-- 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/test/Control/DebounceSpec.hs
new/auto-update-0.2.2/test/Control/DebounceSpec.hs
--- old/auto-update-0.1.6/test/Control/DebounceSpec.hs 2019-07-09
09:40:38.000000000 +0200
+++ new/auto-update-0.2.2/test/Control/DebounceSpec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Control.DebounceSpec (spec) where
+module Control.DebounceSpec (main, spec) where
import Control.Concurrent
import Control.Debounce
@@ -15,22 +14,22 @@
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 +38,30 @@
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 "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)
+ waitUntil 5 $ 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,11 +70,10 @@
waitForBatonToBeTaken baton
debounced
pause
- waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
+ waitUntil 5 $ readIORef ref `shouldReturn` 0
returnFromWait
- waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
-
+ waitUntil 5 $ readIORef ref `shouldReturn` 1
-- | Make a controllable delay function
getWaitAction :: IO (p -> IO (), IO ())
@@ -88,33 +86,38 @@
-- | 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)
+ ref <- newIORef 0
+ let action = modifyIORef ref (+ 1)
- (waitAction, returnFromWait) <- getWaitAction
+ (waitAction, returnFromWait) <- getWaitAction
- baton <- newEmptyMVar
+ baton <- newEmptyMVar
- debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {
- debounceFreq = 5000000 -- unused
- , debounceAction = action
- , debounceEdge = edge
- }
+ debounced <-
+ DI.mkDebounceInternal
+ baton
+ waitAction
+ defaultDebounceSettings
+ { debounceFreq = 5000000 -- unused
+ , debounceAction = action
+ , debounceEdge = edge
+ }
- return (ref, debounced, baton, returnFromWait)
+ return (ref, debounced, baton, returnFromWait)
-- | Pause briefly (100ms)
pause :: IO ()
pause = threadDelay 100000
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)
+ 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.1.6/test/Control/ReaperSpec.hs
new/auto-update-0.2.2/test/Control/ReaperSpec.hs
--- old/auto-update-0.1.6/test/Control/ReaperSpec.hs 2019-07-09
09:40:38.000000000 +0200
+++ new/auto-update-0.2.2/test/Control/ReaperSpec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
