git.iko.soy/typeable/wai
on warp/2.1.2 help sign in
typeable/wai/auto-update/Data/AutoUpdateOld.hs
70 lines 2.6 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2module Data.AutoUpdate where
4import Data.IORef
5import Control.Concurrent (threadDelay, forkIO, ThreadId, killThread, myThreadId)
6import Control.Monad (join, forever)
7import Control.Exception (throwTo, Exception, handle, fromException, throwIO, assert)
8import Data.Typeable (Typeable)
10data UpdateSettings a = UpdateSettings
11 { updateFreq :: !Int
12 , updateSpawnThreshold :: !Int
13 , updateAction :: !(IO a)
14 }
16data Status a = AutoUpdated !a !Int !ThreadId | ManualUpdates !Int
17data AutoUpdate a = AutoUpdate
18 { auSettings :: !(UpdateSettings a)
19 , auStatus :: !(IORef (Status a))
20 }
22mkAutoUpdate :: UpdateSettings a -> IO (AutoUpdate a)
23mkAutoUpdate settings = do
24 istatus <- newIORef $ ManualUpdates 0
25 return $ AutoUpdate settings istatus
27data Action a = Return a | Manual | Spawn
29getCurrent :: AutoUpdate a -> IO a
30getCurrent (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
68data Replaced = Replaced
69 deriving (Show, Typeable)
70instance Exception Replaced