@@ -0,0 +1,156 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+-- | A common problem is the desire to have an action run at a scheduled
4+-- interval, but only if it is needed. For example, instead of having
5+-- every web request result in a new @getCurrentTime@ call, we'd like to
6+-- have a single worker thread run every second, updating an @IORef@.
7+-- However, if the request frequency is less than once per second, this is
8+-- a pessimization, and worse, kills idle GC.
9+--
10+-- This library allows you to define actions which will either be
11+-- performed by a dedicated thread or, in times of low volume, will be
12+-- executed by the calling thread.
13+module Control.AutoUpdate
14+ ( UpdateSettings
15+ , defaultUpdateSettings
16+ , updateFreq
17+ , updateSpawnThreshold
18+ , updateAction
19+ , mkAutoUpdate
20+ ) where
21+
22+import Control.Concurrent (ThreadId, forkIO, killThread, myThreadId,
23+ threadDelay)
24+import Control.Exception (Exception, assert, fromException, handle,
25+ throwIO, throwTo)
26+import Control.Monad (forever, join)
27+import Data.IORef (IORef, atomicModifyIORef, newIORef)
28+import Data.Typeable (Typeable)
29+
30+-- | Default value for creating an @UpdateSettings@.
31+--
32+-- Since 0.1.0
33+defaultUpdateSettings :: UpdateSettings ()
34+defaultUpdateSettings = UpdateSettings
35+ { updateFreq = 1000000
36+ , updateSpawnThreshold = 3
37+ , updateAction = return ()
38+ }
39+
40+-- | Settings to control how values are updated.
41+--
42+-- This should be constructed using @defaultUpdateSettings@ and record
43+-- update syntax, e.g.:
44+--
45+-- @
46+-- let set = defaultUpdateSettings { updateAction = getCurrentTime }
47+-- @
48+--
49+-- Since 0.1.0
50+data UpdateSettings a = UpdateSettings
51+ { updateFreq :: Int
52+ -- ^ Microseconds between update calls. Same considerations as
53+ -- @threadDelay@ apply.
54+ --
55+ -- Default: 1 second (1000000)
56+ --
57+ -- Since 0.1.0
58+ , updateSpawnThreshold :: Int
59+ -- ^ How many times the data must be requested before we decide to
60+ -- spawn a dedicated thread.
61+ --
62+ -- Default: 3
63+ --
64+ -- Since 0.1.0
65+ , updateAction :: IO a
66+ -- ^ Action to be performed to get the current value.
67+ --
68+ -- Default: does nothing.
69+ --
70+ -- Since 0.1.0
71+ }
72+
73+data Status a = AutoUpdated
74+ !a
75+ {-# UNPACK #-} !Int
76+ -- Number of times used since last updated.
77+ {-# UNPACK #-} !ThreadId
78+ -- Worker thread.
79+ | ManualUpdates
80+ {-# UNPACK #-} !Int
81+ -- Number of times used since we started/switched
82+ -- off manual updates.
83+
84+-- | A value which will be updated, either via a dedicated thread or when
85+-- requested. Request the current value with @getCurrent@.
86+--
87+-- Since 0.1.0
88+data AutoUpdate a = AutoUpdate
89+-- We use bang patterns on all arguments to ensure no bottoms leak in.
90+ { auFreq :: {-# UNPACK #-} !Int
91+ , auSpawnThreadhold :: {-# UNPACK #-} !Int
92+ , auAction :: !(IO ())
93+ , auStatus :: !(IORef (Status a))
94+ }
95+
96+-- | Generate an action which will either read from an automatically
97+-- updated value, or run the update action in the current thread.
98+--
99+-- Since 0.1.0
100+mkAutoUpdate :: UpdateSettings a -> IO (IO a)
101+mkAutoUpdate (UpdateSettings !f !t !a) = do
102+ istatus <- newIORef $ ManualUpdates 0
103+ return $! getCurrent f t a istatus
104+
105+data Action a = Return a | Manual | Spawn
106+
107+-- | Get the current value, either fed from an auto-update thread, or
108+-- computed manually in the current thread.
109+--
110+-- Since 0.1.0
111+getCurrent :: Int -- ^ frequency
112+ -> Int -- ^ spawn threshold
113+ -> IO a -- ^ internal update action
114+ -> IORef (Status a) -- ^ mutable state
115+ -> IO a
116+getCurrent freq spawnThreshold action istatus = do
117+ ea <- atomicModifyIORef istatus $ \status ->
118+ case status of
119+ AutoUpdated a cnt tid -> (AutoUpdated a (succ cnt) tid, Return a)
120+ ManualUpdates i -> (ManualUpdates (succ i), if i > spawnThreshold then Spawn else Manual)
121+ case ea of
122+ Return a -> return a
123+ Manual -> action
124+ Spawn -> do
125+ a <- action
126+ tid <- forkIO spawn
127+ join $ atomicModifyIORef istatus $ \status ->
128+ case status of
129+ AutoUpdated _ cnt old -> (AutoUpdated a cnt tid, throwTo old Replaced)
130+ ManualUpdates cnt -> (AutoUpdated a cnt tid, return ())
131+ return a
132+ where
133+ spawn = handle onErr $ forever $ do
134+ threadDelay freq
135+ a <- action
136+ let stop = throwIO Replaced
137+ join $ atomicModifyIORef istatus $ \status ->
138+ case status of
139+ AutoUpdated _ cnt tid
140+ | cnt >= 1 -> (AutoUpdated a 0 tid, return ())
141+ | otherwise -> (ManualUpdates 0, stop)
142+ ManualUpdates i -> assert False (ManualUpdates i, stop)
143+ onErr ex =
144+ case fromException ex of
145+ Just Replaced -> return ()
146+ Nothing -> do
147+ tid <- myThreadId
148+ atomicModifyIORef istatus $ \status ->
149+ case status of
150+ AutoUpdated _ _ tid' | tid == tid' -> (ManualUpdates 0, ())
151+ _ -> (status, ())
152+ throwIO ex
153+
154+data Replaced = Replaced
155+ deriving (Show, Typeable)
156+instance Exception Replaced