1-- | A common problem is the desire to have an action run at a scheduled
2-- interval, but only if it is needed. For example, instead of having
3-- every web request result in a new @getCurrentTime@ call, we'd like to
4-- have a single worker thread run every second, updating an @IORef@.
5-- However, if the request frequency is less than once per second, this is
6-- a pessimization, and worse, kills idle GC.
8-- This library allows you to define actions which will either be
9-- performed by a dedicated thread or, in times of low volume, will be
10-- executed by the calling thread.
11module Control.AutoUpdate (
14 , defaultUpdateSettings
17 , updateSpawnThreshold
23import Control.Concurrent (forkIO, threadDelay)
24import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
26import Control.Exception (SomeException, catch, throw, mask_, try)
27import Control.Monad (void)
28import Data.IORef (newIORef, readIORef, writeIORef)
30-- | Default value for creating an @UpdateSettings@.
33defaultUpdateSettings :: UpdateSettings ()
34defaultUpdateSettings = UpdateSettings
35 { updateFreq = 1000000
36 , updateSpawnThreshold = 3
37 , updateAction = return ()
40-- | Settings to control how values are updated.
42-- This should be constructed using @defaultUpdateSettings@ and record
43-- update syntax, e.g.:
46-- let set = defaultUpdateSettings { updateAction = getCurrentTime }
50data UpdateSettings a = UpdateSettings
52 -- ^ Microseconds between update calls. Same considerations as
53 -- @threadDelay@ apply.
55 -- Default: 1 second (1000000)
58 , updateSpawnThreshold :: Int
59 -- ^ NOTE: This value no longer has any effect, since worker threads are
60 -- dedicated instead of spawned on demand.
62 -- Previously, this determined: How many times the data must be requested
63 -- before we decide to spawn a dedicated thread.
68 , updateAction :: IO a
69 -- ^ Action to be performed to get the current value.
71 -- Default: does nothing.
76-- | Generate an action which will either read from an automatically
77-- updated value, or run the update action in the current thread.
80mkAutoUpdate :: UpdateSettings a -> IO (IO a)
82 -- A baton to tell the worker thread to generate a new value.
83 needsRunning <- newEmptyMVar
85 -- The initial response variable. Response variables allow the requesting
86 -- thread to block until a value is generated by the worker thread.
87 responseVar0 <- newEmptyMVar
89 -- The current value, if available. We start off with a Left value
90 -- indicating no value is available, and the above-created responseVar0 to
91 -- give a variable to block on.
92 currRef <- newIORef $ Left responseVar0
94 -- This is used to set a value in the currRef variable when the worker
95 -- thread exits. In reality, that value should never be used, since the
96 -- worker thread exiting only occurs if an async exception is thrown, which
97 -- should only occur if there are no references to needsRunning left.
98 -- However, this handler will make error messages much clearer if there's a
99 -- bug in the implementation.
100 let fillRefOnExit f = do
103 Left e -> writeIORef currRef $ error $
104 "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
105 ++ show (e :: SomeException)
106 Right () -> writeIORef currRef $ error $
107 "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
108 ++ "which should be impossible due to usage of infinite loop"
110 -- fork the worker thread immediately. Note that we mask async exceptions,
111 -- but *not* in an uninterruptible manner. This will allow a
112 -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
113 -- down this thread when all references to the returned function are
114 -- garbage collected, and therefore there is no thread that can fill the
115 -- needsRunning MVar.
117 -- Note that since we throw away the ThreadId of this new thread and never
118 -- calls myThreadId, normal async exceptions can never be thrown to it,
119 -- only RTS exceptions.
120 mask_ $ void $ forkIO $ fillRefOnExit $ do
121 -- This infinite loop makes up out worker thread. It takes an a
122 -- responseVar value where the next value should be putMVar'ed to for
123 -- the benefit of any requesters currently blocked on it.
124 let loop responseVar = do
125 -- block until a value is actually needed
126 takeMVar needsRunning
128 -- new value requested, so run the updateAction
129 a <- catchSome $ updateAction us
131 -- we got a new value, update currRef and lastValue
132 writeIORef currRef $ Right a
133 putMVar responseVar a
135 -- delay until we're needed again
136 threadDelay $ updateFreq us
138 -- delay's over. create a new response variable and set currRef
139 -- to use it, so that the next requester will block on that
140 -- variable. Then loop again with the updated response
142 responseVar' <- newEmptyMVar
143 writeIORef currRef $ Left responseVar'
146 -- Kick off the loop, with the initial responseVar0 variable.
150 mval <- readIORef currRef
152 Left responseVar -> do
153 -- no current value, force the worker thread to run...
154 void $ tryPutMVar needsRunning ()
156 -- and block for the result from the worker
158 -- we have a current value, use it
159 Right val -> return val
161-- | Turn a runtime exception into an impure exception, so that all @IO@
162-- actions will complete successfully. This simply defers the exception until
163-- the value is forced.
164catchSome :: IO a -> IO a
165catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list