git.iko.soy/typeable/wai
on 98fc1d2 help sign in
typeable/wai/auto-update/Control/AutoUpdate.hs
201 lines 8.1 kB history raw
1{-# LANGUAGE CPP #-}
2-- | In a multithreaded environment, running actions on a regularly scheduled
3-- background thread can dramatically improve performance.
4-- For example, web servers need to return the current time with each HTTP response.
5-- For a high-volume server, it's much faster for a dedicated thread to run every
6-- second, and write the current time to a shared 'IORef', than it is for each
7-- request to make its own call to 'getCurrentTime'.
8--
9-- But for a low-volume server, whose request frequency is less than once per
10-- second, that approach will result in /more/ calls to 'getCurrentTime' than
11-- necessary, and worse, kills idle GC.
12--
13-- This library solves that problem by allowing you to define actions which will
14-- either be performed by a dedicated thread, or, in times of low volume, will
15-- be executed by the calling thread.
16--
17-- Example usage:
18--
19-- @
20-- import "Data.Time"
21-- import "Control.AutoUpdate"
22--
23-- getTime <- 'mkAutoUpdate' 'defaultUpdateSettings'
24-- { 'updateAction' = 'Data.Time.Clock.getCurrentTime'
25-- , 'updateFreq' = 1000000 -- The default frequency, once per second
26-- }
27-- currentTime <- getTime
28-- @
29--
30-- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>.
31module Control.AutoUpdate (
32 -- * Type
33 UpdateSettings
34 , defaultUpdateSettings
35 -- * Accessors
36 , updateAction
37 , updateFreq
38 , updateSpawnThreshold
39 -- * Creation
40 , mkAutoUpdate
41 , mkAutoUpdateWithModify
42 ) where
44#if __GLASGOW_HASKELL__ < 709
45import Control.Applicative ((<*>))
46#endif
47import Control.Concurrent (forkIO, threadDelay)
48import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
49 takeMVar, tryPutMVar)
50import Control.Exception (SomeException, catch, mask_, throw,
51 try)
52import Control.Monad (void)
53import Data.IORef (newIORef, readIORef, writeIORef)
55-- | Default value for creating an 'UpdateSettings'.
56--
57-- @since 0.1.0
58defaultUpdateSettings :: UpdateSettings ()
59defaultUpdateSettings = UpdateSettings
60 { updateFreq = 1000000
61 , updateSpawnThreshold = 3
62 , updateAction = return ()
63 }
65-- | Settings to control how values are updated.
66--
67-- This should be constructed using 'defaultUpdateSettings' and record
68-- update syntax, e.g.:
69--
70-- @
71-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }
72-- @
73--
74-- @since 0.1.0
75data UpdateSettings a = UpdateSettings
76 { updateFreq :: Int
77 -- ^ Microseconds between update calls. Same considerations as
78 -- 'threadDelay' apply.
79 --
80 -- Default: 1 second (1000000)
81 --
82 -- @since 0.1.0
83 , updateSpawnThreshold :: Int
84 -- ^ NOTE: This value no longer has any effect, since worker threads are
85 -- dedicated instead of spawned on demand.
86 --
87 -- Previously, this determined how many times the data must be requested
88 -- before we decide to spawn a dedicated thread.
89 --
90 -- Default: 3
91 --
92 -- @since 0.1.0
93 , updateAction :: IO a
94 -- ^ Action to be performed to get the current value.
95 --
96 -- Default: does nothing.
97 --
98 -- @since 0.1.0
99 }
101-- | Generate an action which will either read from an automatically
102-- updated value, or run the update action in the current thread.
103--
104-- @since 0.1.0
105mkAutoUpdate :: UpdateSettings a -> IO (IO a)
106mkAutoUpdate us = mkAutoUpdateHelper us Nothing
108-- | Generate an action which will either read from an automatically
109-- updated value, or run the update action in the current thread if
110-- the first time or the provided modify action after that.
111--
112-- @since 0.1.4
113mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)
114mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)
116mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
117mkAutoUpdateHelper us updateActionModify = do
118 -- A baton to tell the worker thread to generate a new value.
119 needsRunning <- newEmptyMVar
121 -- The initial response variable. Response variables allow the requesting
122 -- thread to block until a value is generated by the worker thread.
123 responseVar0 <- newEmptyMVar
125 -- The current value, if available. We start off with a Left value
126 -- indicating no value is available, and the above-created responseVar0 to
127 -- give a variable to block on.
128 currRef <- newIORef $ Left responseVar0
130 -- This is used to set a value in the currRef variable when the worker
131 -- thread exits. In reality, that value should never be used, since the
132 -- worker thread exiting only occurs if an async exception is thrown, which
133 -- should only occur if there are no references to needsRunning left.
134 -- However, this handler will make error messages much clearer if there's a
135 -- bug in the implementation.
136 let fillRefOnExit f = do
137 eres <- try f
138 case eres of
139 Left e -> writeIORef currRef $ error $
140 "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
141 ++ show (e :: SomeException)
142 Right () -> writeIORef currRef $ error $
143 "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
144 ++ "which should be impossible due to usage of infinite loop"
146 -- fork the worker thread immediately. Note that we mask async exceptions,
147 -- but *not* in an uninterruptible manner. This will allow a
148 -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
149 -- down this thread when all references to the returned function are
150 -- garbage collected, and therefore there is no thread that can fill the
151 -- needsRunning MVar.
152 --
153 -- Note that since we throw away the ThreadId of this new thread and never
154 -- calls myThreadId, normal async exceptions can never be thrown to it,
155 -- only RTS exceptions.
156 mask_ $ void $ forkIO $ fillRefOnExit $ do
157 -- This infinite loop makes up out worker thread. It takes an a
158 -- responseVar value where the next value should be putMVar'ed to for
159 -- the benefit of any requesters currently blocked on it.
160 let loop responseVar maybea = do
161 -- block until a value is actually needed
162 takeMVar needsRunning
164 -- new value requested, so run the updateAction
165 a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)
167 -- we got a new value, update currRef and lastValue
168 writeIORef currRef $ Right a
169 putMVar responseVar a
171 -- delay until we're needed again
172 threadDelay $ updateFreq us
174 -- delay's over. create a new response variable and set currRef
175 -- to use it, so that the next requester will block on that
176 -- variable. Then loop again with the updated response
177 -- variable.
178 responseVar' <- newEmptyMVar
179 writeIORef currRef $ Left responseVar'
180 loop responseVar' (Just a)
182 -- Kick off the loop, with the initial responseVar0 variable.
183 loop responseVar0 Nothing
185 return $ do
186 mval <- readIORef currRef
187 case mval of
188 Left responseVar -> do
189 -- no current value, force the worker thread to run...
190 void $ tryPutMVar needsRunning ()
192 -- and block for the result from the worker
193 readMVar responseVar
194 -- we have a current value, use it
195 Right val -> return val
197-- | Turn a runtime exception into an impure exception, so that all 'IO'
198-- actions will complete successfully. This simply defers the exception until
199-- the value is forced.
200catchSome :: IO a -> IO a
201catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)