git.iko.soy/typeable/wai
on master help sign in
importing auto-update.
57997e2Kazu Yamamoto
auto-update/Data/AutoUpdate.hsnew file+107
compare with master
unifiedsplit
@@ -0,0 +1,107 @@
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.hsnew file+70
@@ -0,0 +1,70 @@
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/README.mdnew file+1
@@ -0,0 +1 @@
1+See https://github.com/yesodweb/yesod-scaffold/pull/15