@@ -0,0 +1,130 @@
1+-- | This module provides the ability to create reapers: dedicated cleanup
2+-- threads. These threads will automatically spawn and die based on the
3+-- presence of a workload to process on.
4+module Control.Reaper
5+ ( ReaperSettings
6+ , reaper
7+ , defaultReaperSettings
8+ , reaperAction
9+ , reaperDelay
10+ , reaperCons
11+ , reaperNull
12+ , mkListAction
13+ ) where
14+
15+import Prelude hiding (null)
16+import Data.Monoid (Monoid, mempty)
17+import Control.Monad (join, void)
18+import Data.Function (fix)
19+import Control.AutoUpdate.Util (atomicModifyIORef')
20+import Control.Concurrent (forkIO, threadDelay)
21+import Data.IORef (newIORef)
22+import Control.Exception (mask_)
23+import qualified Prelude
24+
25+-- | Settings for creating a reaper. This type has two parameters:
26+-- @workload@ gives the entire workload, whereas @item@ gives an
27+-- individual piece of the queue. A common approach is to have @workload@
28+-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and
29+-- 'mkListAction'.
30+--
31+-- Since 0.1.1
32+data ReaperSettings workload item = ReaperSettings
33+ { reaperAction :: workload -> IO (workload -> workload)
34+ -- ^ The action to perform on a workload. The result of this is a
35+ -- \"workload modifying\" function. In the common case of using lists,
36+ -- the result should be a difference list that prepends the remaining
37+ -- workload to the temporary workload. For help with setting up such
38+ -- an action, see 'mkListAction'.
39+ --
40+ -- Default: do nothing with the workload, and then prepend it to the
41+ -- temporary workload. This is incredibly useless; you should
42+ -- definitely override this default.
43+ --
44+ -- Since 0.1.1
45+ , reaperDelay :: {-# UNPACK #-} !Int
46+ -- ^ Number of microseconds to delay between calls of 'reaperAction'.
47+ --
48+ -- Default: 30 seconds.
49+ --
50+ -- Since 0.1.1
51+ , reaperCons :: item -> workload -> workload
52+ -- ^ Add an item onto a workload.
53+ --
54+ -- Default: list consing.
55+ --
56+ -- Since 0.1.1
57+ , reaperNull :: workload -> Bool
58+ -- ^ Check if a workload is empty, in which case the worker thread
59+ -- will shut down.
60+ --
61+ -- Default: 'Prelude.null'.
62+ --
63+ -- Since 0.1.1
64+ }
65+
66+-- | Default @ReaperSettings@ value, biased towards having a list of work
67+-- items.
68+--
69+-- Since 0.1.1
70+defaultReaperSettings :: ReaperSettings [item] item
71+defaultReaperSettings = ReaperSettings
72+ { reaperAction = \wl -> return (wl ++)
73+ , reaperDelay = 30000000
74+ , reaperCons = (:)
75+ , reaperNull = Prelude.null
76+ }
77+
78+-- | Create a reaper addition function. This funciton can be used to add
79+-- new items to the workload. Spawning of reaper threads will be handled
80+-- for you automatically.
81+--
82+-- Since 0.1.1
83+reaper :: Monoid workload
84+ => ReaperSettings workload item
85+ -> IO (item -> IO ())
86+reaper (ReaperSettings action delay cons null) = do
87+ stateRef <- newIORef Nothing
88+ return (update stateRef)
89+ where
90+ update stateRef item = mask_ $ join $ atomicModifyIORef' stateRef $ \ms ->
91+ case ms of
92+ Nothing -> (Just $ cons item mempty, spawn stateRef)
93+ Just wl -> (Just $ cons item wl, return ())
94+
95+ spawn stateRef = void $ forkIO $ fix $ \loop -> do
96+ threadDelay delay
97+ wl1 <- atomicModifyIORef' stateRef $ \ms ->
98+ case ms of
99+ Nothing -> error "Control.Reaper.reaper.spawn: unexpected Nothing (1)"
100+ Just wl -> (Just mempty, wl)
101+ wl2 <- action wl1
102+ join $ atomicModifyIORef' stateRef $ \ms ->
103+ case ms of
104+ Nothing -> error "Control.Reaper.reaper.spawn: unexpected Nothing (2)"
105+ Just wl3 ->
106+ let wl4 = wl2 wl3
107+ in if null wl4
108+ then (Nothing, return ())
109+ else (Just wl4, loop)
110+
111+-- | A helper function for creating 'reaperAction' functions. You would
112+-- provide this function with a function to process a single work item and
113+-- return either a new work item, or @Nothing@ if the work item is
114+-- expired.
115+--
116+-- Since 0.1.1
117+mkListAction :: (item -> IO (Maybe item'))
118+ -> [item]
119+ -> IO ([item'] -> [item'])
120+mkListAction f =
121+ loop id
122+ where
123+ loop front [] = return front
124+ loop front (x:xs) = do
125+ my <- f x
126+ let front' =
127+ case my of
128+ Nothing -> front
129+ Just y -> front . (y:)
130+ loop front' xs