git.iko.soy/typeable/wai
on master help sign in
Cabalize and clean up auto-update
81b9561Michael Snoyman
auto-update/Control/AutoUpdate.hsnew file+156
compare with master
unifiedsplit
@@ -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
auto-update/Data/AutoUpdate.hsdeleted−107
@@ -1,107 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
2−-- FIXME: should we replace Data with System?
3−module Data.AutoUpdate where
4−
5−import Control.Applicative ((<$>))
6−import Data.IORef
7−import Control.Concurrent (threadDelay, forkIOWithUnmask)
8−import Control.Monad (forever, void)
9−import Control.Exception (Exception, SomeException(..), handle, catches, throwIO, assert, Handler(..), mask)
10−import Data.Typeable (Typeable)
11−
12−----------------------------------------------------------------
13−
14−data UpdateSettings a = UpdateSettings
15− { updateFreq :: !Int
16− , updateSpawnThreshold :: !Int
17− , updateAction :: !(IO a)
18− }
19−
20−data Status a = AutoUpdated !a !Int -- ^ # of manual update during updateFreq
21− | SemiAuto
22− | ManualUpdates !Int -- ^ # of manual update
23−
24−data AutoUpdate a = AutoUpdate
25− { auSettings :: !(UpdateSettings a)
26− , auStatus :: !(IORef (Status a))
27− }
28−
29−data Action a = Return a | Manual | Spawn
30−
31−data Replaced = Replaced deriving (Show, Typeable)
32−instance Exception Replaced
33−
34−----------------------------------------------------------------
35−
36−mkAutoUpdate :: UpdateSettings a -> IO (AutoUpdate a)
37−mkAutoUpdate settings = AutoUpdate settings <$> newIORef (ManualUpdates 0)
38−
39−getCurrent :: AutoUpdate a -> IO a
40−getCurrent au@(AutoUpdate (UpdateSettings _ spawnThreshold action) istatus) =
41− handle handler update
42− where
43− update = mask $ \restore -> do
44− ea <- atomicModifyIORef' istatus increment
45− case ea of
46− Return a -> return a
47− Manual -> restore action
48− Spawn -> do
49− a <- restore action
50− void $ forkIOWithUnmask $ spawn au a
51− -- Without mask, an asynchronous exeption here may lead
52− -- to spawn multiple threads.
53− return a
54−
55− increment (AutoUpdated a cnt) = (AutoUpdated a (succ cnt), Return a)
56− increment SemiAuto = (SemiAuto, Manual)
57− increment (ManualUpdates i)
58− | i > spawnThreshold = (SemiAuto, Spawn)
59− | otherwise = (ManualUpdates (succ i), Manual)
60−
61− handler (SomeException ex) = do
62− atomicModifyIORef' istatus reset
63− throwIO ex
64−
65− -- Resetting to the safe status
66− reset SemiAuto = (ManualUpdates 0, ())
67− -- If status is AutoUpdated, an thread is running.
68− -- So, let's keep the status.
69− reset status = (status, ())
70−
71−----------------------------------------------------------------
72−
73−spawn :: AutoUpdate a -> a -> (forall b. IO b -> IO b) -> IO ()
74−spawn (AutoUpdate (UpdateSettings freq _ action) istatus) x restore =
75− update `catches` handlers
76− where
77− update = do
78− void $ atomicModifyIORef' istatus (turnToAuto x)
79− restore loop
80−
81− turnToAuto a _ = (AutoUpdated a 0, ())
82−
83− loop = forever $ do
84− threadDelay freq
85− a <- action
86− doit <- atomicModifyIORef' istatus $ trunToManual a
87− doit
88−
89− -- Normal case.
90− trunToManual a (AutoUpdated _ cnt)
91− | cnt >= 1 = (AutoUpdated a 0, return ())
92− | otherwise = (ManualUpdates 0, stop)
93− -- This case must not happen.
94− trunToManual _ _ = assert False (ManualUpdates 0, stop)
95−
96− stop :: IO a
97− stop = throwIO Replaced
98−
99− handlers :: [Handler ()]
100− handlers = [Handler rhandler, Handler ohandler]
101−
102− rhandler Replaced = return ()
103− ohandler (SomeException ex) = do
104− -- This thread is killed.
105− -- Resetting to the safe status.
106− atomicModifyIORef' istatus $ \_ -> (ManualUpdates 0, ())
107− throwIO ex
auto-update/Data/AutoUpdateOld.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Data.AutoUpdate where
3−
4−import Data.IORef
5−import Control.Concurrent (threadDelay, forkIO, ThreadId, killThread, myThreadId)
6−import Control.Monad (join, forever)
7−import Control.Exception (throwTo, Exception, handle, fromException, throwIO, assert)
8−import Data.Typeable (Typeable)
9−
10−data UpdateSettings a = UpdateSettings
11− { updateFreq :: !Int
12− , updateSpawnThreshold :: !Int
13− , updateAction :: !(IO a)
14− }
15−
16−data Status a = AutoUpdated !a !Int !ThreadId | ManualUpdates !Int
17−data AutoUpdate a = AutoUpdate
18− { auSettings :: !(UpdateSettings a)
19− , auStatus :: !(IORef (Status a))
20− }
21−
22−mkAutoUpdate :: UpdateSettings a -> IO (AutoUpdate a)
23−mkAutoUpdate settings = do
24− istatus <- newIORef $ ManualUpdates 0
25− return $ AutoUpdate settings istatus
26−
27−data Action a = Return a | Manual | Spawn
28−
29−getCurrent :: AutoUpdate a -> IO a
30−getCurrent (AutoUpdate (UpdateSettings freq spawnThreshold action) istatus) = do
31− ea <- atomicModifyIORef istatus $ \status ->
32− case status of
33− AutoUpdated a cnt tid -> (AutoUpdated a (succ cnt) tid, Return a)
34− ManualUpdates i -> (ManualUpdates (succ i), if i > spawnThreshold then Spawn else Manual)
35− case ea of
36− Return a -> return a
37− Manual -> action
38− Spawn -> do
39− a <- action
40− tid <- forkIO spawn
41− join $ atomicModifyIORef istatus $ \status ->
42− case status of
43− AutoUpdated _ cnt old -> (AutoUpdated a cnt tid, throwTo old Replaced)
44− ManualUpdates cnt -> (AutoUpdated a cnt tid, return ())
45− return a
46− where
47− spawn = handle onErr $ forever $ do
48− threadDelay freq
49− a <- action
50− let stop = throwIO Replaced
51− join $ atomicModifyIORef istatus $ \status ->
52− case status of
53− AutoUpdated _ cnt tid
54− | cnt >= 1 -> (AutoUpdated a 0 tid, return ())
55− | otherwise -> (ManualUpdates 0, stop)
56− ManualUpdates i -> assert False (ManualUpdates i, stop)
57− onErr ex =
58− case fromException ex of
59− Just Replaced -> return ()
60− Nothing -> do
61− tid <- myThreadId
62− atomicModifyIORef istatus $ \status ->
63− case status of
64− AutoUpdated _ _ tid' | tid == tid' -> (ManualUpdates 0, ())
65− _ -> (status, ())
66− throwIO ex
67−
68−data Replaced = Replaced
69− deriving (Show, Typeable)
70−instance Exception Replaced
auto-update/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2014 Michael Snoyman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
auto-update/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
auto-update/auto-update.cabalnew file+29
@@ -0,0 +1,29 @@
1+name: auto-update
2+version: 0.1.0.0
3+synopsis: Efficiently run periodic, on-demand actions
4+description:
5+ A common problem is the desire to have an action run at a scheduled interval, but only if it is needed. For example, instead of having every web request result in a new @getCurrentTime@ call, we'd like to have a single worker thread run every second, updating an @IORef@. However, if the request frequency is less than once per second, this is a pessimization, and worse, kills idle GC.
6+ .
7+ This library allows you to define actions which will either be performed by a dedicated thread or, in times of low volume, will be executed by the calling thread.
8+homepage: https://github.com/yesodweb/wai
9+license: MIT
10+license-file: LICENSE
11+author: Michael Snoyman
12+maintainer: michael@snoyman.com
13+category: Control
14+build-type: Simple
15+extra-source-files: README.md
16+cabal-version: >=1.10
17+
18+library
19+ exposed-modules: Control.AutoUpdate
20+ build-depends: base >= 4 && < 5
21+ default-language: Haskell2010
22+
23+test-suite spec
24+ main-is: Spec.hs
25+ other-modules: Control.AutoUpdateSpec
26+ hs-source-dirs: test
27+ type: exitcode-stdio-1.0
28+ build-depends: base, auto-update, hspec
29+ default-language: Haskell2010
auto-update/test/Control/AutoUpdateSpec.hsnew file+34
@@ -0,0 +1,34 @@
1+module Control.AutoUpdateSpec (spec) where
2+
3+import Test.Hspec
4+import Test.Hspec.QuickCheck
5+import Data.IORef
6+import Control.Concurrent (threadDelay)
7+import Control.Monad (replicateM_, forM_)
8+import Control.AutoUpdate
9+
10+spec :: Spec
11+spec = do
12+ prop "incrementer" $ \st' -> do
13+ let st = abs st'
14+ ref <- newIORef 0
15+ next <- mkAutoUpdate defaultUpdateSettings
16+ { updateAction = atomicModifyIORef ref $ \i ->
17+ let i' = succ i in i' `seq` (i', i')
18+ , updateSpawnThreshold = st
19+ , updateFreq = 10000
20+ }
21+
22+ forM_ [1..st + 1] $ \i -> do
23+ j <- next
24+ j `shouldBe` i
25+
26+ replicateM_ 50 $ do
27+ i <- next
28+ i `shouldBe` st + 2
29+
30+ threadDelay 60000
31+ last1 <- readIORef ref
32+ threadDelay 20000
33+ last2 <- readIORef ref
34+ last2 `shouldBe` last1
auto-update/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
sources.txt+1
@@ -11,3 +11,4 @@
11./wai-eventsource
11./wai-eventsource
12./wai-conduit
12./wai-conduit
13./mime-types
13./mime-types
14+./auto-update