@@ -3,8 +3,18 @@
33
44-- | This module provides the ability to create reapers: dedicated cleanup
55-- threads. These threads will automatically spawn and die based on the
6−-- presence of a workload to process on.
6+-- presence of a workload to process on. Example uses include:
7+--
8+-- * Killing long-running jobs (see example below)
9+-- * Closing unused connections in a connection pool
10+-- * Pruning a cache of old items
11+--
12+-- For real-world usage, search the <https://github.com/yesodweb/wai WAI family of packages>
13+-- for imports of "Control.Reaper".
714module Control.Reaper (
15+ -- * Example: A small jobs system
16+ -- $example1
17+
818 -- * Settings
919 ReaperSettings
1020 , defaultReaperSettings
@@ -33,7 +43,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3343-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and
3444-- 'mkListAction'.
3545--
36−-- Since 0.1.1
46+-- @since 0.1.1
3747data ReaperSettings workload item = ReaperSettings
3848 { reaperAction :: workload -> IO (workload -> workload)
3949 -- ^ The action to perform on a workload. The result of this is a
@@ -46,38 +56,38 @@ data ReaperSettings workload item = ReaperSettings
4656 -- temporary workload. This is incredibly useless; you should
4757 -- definitely override this default.
4858 --
49− -- Since 0.1.1
59+ -- @since 0.1.1
5060 , reaperDelay :: {-# UNPACK #-} !Int
5161 -- ^ Number of microseconds to delay between calls of 'reaperAction'.
5262 --
5363 -- Default: 30 seconds.
5464 --
55− -- Since 0.1.1
65+ -- @since 0.1.1
5666 , reaperCons :: item -> workload -> workload
5767 -- ^ Add an item onto a workload.
5868 --
5969 -- Default: list consing.
6070 --
61− -- Since 0.1.1
71+ -- @since 0.1.1
6272 , reaperNull :: workload -> Bool
6373 -- ^ Check if a workload is empty, in which case the worker thread
6474 -- will shut down.
6575 --
6676 -- Default: 'null'.
6777 --
68− -- Since 0.1.1
78+ -- @since 0.1.1
6979 , reaperEmpty :: workload
7080 -- ^ An empty workload.
7181 --
7282 -- Default: empty list.
7383 --
74− -- Since 0.1.1
84+ -- @since 0.1.1
7585 }
7686
7787-- | Default @ReaperSettings@ value, biased towards having a list of work
7888-- items.
7989--
80−-- Since 0.1.1
90+-- @since 0.1.1
8191defaultReaperSettings :: ReaperSettings [item] item
8292defaultReaperSettings = ReaperSettings
8393 { reaperAction = \wl -> return (wl ++)
@@ -104,11 +114,11 @@ data Reaper workload item = Reaper {
104114data State workload = NoReaper -- ^ No reaper thread
105115 | Workload workload -- ^ The current jobs
106116
107−-- | Create a reaper addition function. This funciton can be used to add
117+-- | Create a reaper addition function. This function can be used to add
108118-- new items to the workload. Spawning of reaper threads will be handled
109119-- for you automatically.
110120--
111−-- Since 0.1.1
121+-- @since 0.1.1
112122mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
113123mkReaper settings@ReaperSettings{..} = do
114124 stateRef <- newIORef NoReaper
@@ -187,7 +197,7 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do
187197-- return either a new work item, or @Nothing@ if the work item is
188198-- expired.
189199--
190−-- Since 0.1.1
200+-- @since 0.1.1
191201mkListAction :: (item -> IO (Maybe item'))
192202 -> [item]
193203 -> IO ([item'] -> [item'])
@@ -202,3 +212,73 @@ mkListAction f =
202212 Nothing -> front
203213 Just y -> front . (y:)
204214 go front' xs
215+
216+-- $example1
217+-- In this example code, we create a small jobs system.
218+-- The @main@ function first creates a 'Reaper' to manage our jobs,
219+-- then starts 10 jobs that each take 1 to 10 seconds to complete.
220+-- Each Job is added to the Reaper's workload (a list of Jobs).
221+--
222+-- Every second, the 'Reaper' will traverse the list of jobs, removing completed ones,
223+-- and killing ones that have run longer than 5 seconds.
224+--
225+-- Once all jobs are completed or killed, the 'Reaper''s own thread will die.
226+--
227+-- @
228+-- {-\# LANGUAGE MultiWayIf #-}
229+--
230+-- module Main where
231+--
232+-- import "Data.Time"
233+-- import "System.Random"
234+-- import "Control.Reaper"
235+-- import "Control.Concurrent"
236+-- import "Control.Monad"
237+-- import "Data.IORef"
238+--
239+-- -- In this example code, we add Jobs (the individual items) to our Reaper's workload (a list of Jobs)
240+-- data Job = Job { jobID :: 'Int'
241+-- , jobStarted :: 'Data.Time.Clock.UTCTime'
242+-- , jobThreadId :: 'ThreadId'
243+-- , jobFinished :: 'IORef' 'Bool'
244+-- }
245+--
246+-- main :: IO ()
247+-- main = do
248+-- reaper <- 'mkReaper' 'defaultReaperSettings'
249+-- { 'reaperAction' = 'mkListAction' maybeReapJob
250+-- , 'reaperDelay' = 1000000 -- Check for completed/valid jobs every second.
251+-- }
252+-- 'forM_' [1..10] $ \\i -> do
253+-- job <- startJob i
254+-- ('reaperAdd' reaper) job
255+--
256+-- 'threadDelay' 1500000 -- Sleep 15 seconds, so that jobs can be completed or killed.
257+--
258+-- -- Start a variable-length task that takes between 1 and 10 seconds
259+-- startJob :: Int -> IO Job
260+-- startJob aJobID = do
261+-- startTime <- 'Data.Time.Clock.getCurrentTime'
262+-- finishedRef <- 'newIORef' 'False'
263+-- threadID <- 'forkIO' $ do
264+-- secondsToWait <- 'System.Random.getStdRandom' ('System.Random.randomR' (1,10))
265+-- 'threadDelay' (secondsToWait * 1000000)
266+-- 'Data.IORef.atomicWriteIORef' finishedRef 'True' -- Mark the job as complete.
267+-- 'return' $ Job aJobID startTime threadID finishedRef
268+--
269+-- -- Remove completed jobs, and also kill ones that have run longer than 5 seconds.
270+-- maybeReapJob :: Job -> IO (Maybe Job)
271+-- maybeReapJob job = do
272+-- currentTime <- 'Data.Time.Clock.getCurrentTime'
273+-- let runningTime = currentTime \`diffUTCTime\` (jobStarted job)
274+-- jobDone <- 'readIORef' (jobFinished job)
275+--
276+-- if | jobDone -> do
277+-- 'putStrLn' $ "Completed job #" ++ 'show' (jobID job)
278+-- 'return' 'Nothing'
279+-- | runningTime > 5.0 -> do
280+-- 'killThread' (jobThreadId job)
281+-- 'putStrLn' $ "Killed job #" ++ 'show' (jobID job)
282+-- 'return' 'Nothing'
283+-- | otherwise -> 'return' ('Just' job)
284+-- @