auto-update (empty) → 0.1.0.0
raw patch · 7 files changed
+275/−0 lines, 7 filesdep +auto-updatedep +basedep +hspecsetup-changed
Dependencies added: auto-update, base, hspec
Files
- Control/AutoUpdate.hs +184/−0
- LICENSE +20/−0
- README.md +5/−0
- Setup.hs +2/−0
- auto-update.cabal +29/−0
- test/Control/AutoUpdateSpec.hs +34/−0
- test/Spec.hs +1/−0
+ Control/AutoUpdate.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}++-- | 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.+--+-- 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.+module Control.AutoUpdate+ ( UpdateSettings+ , defaultUpdateSettings+ , updateFreq+ , updateSpawnThreshold+ , updateAction+ , mkAutoUpdate+ ) where++import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)+import Control.Exception (Exception, SomeException+ ,assert, fromException, handle,throwIO, throwTo)+import Control.Monad (forever, join)+import Data.IORef (IORef, newIORef)+import Data.Typeable (Typeable)++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#if MIN_VERSION_base(4,6,0)+import Data.IORef (atomicModifyIORef')+#else+import Data.IORef (atomicModifyIORef)+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored+-- in the 'IORef' as well as the value returned.+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef' ref f = do+ c <- atomicModifyIORef ref+ (\x -> let (a, b) = f x -- Lazy application of "f"+ in (a, a `seq` b)) -- Lazy application of "seq"+ -- The following forces "a `seq` b", so it also forces "f x".+ c `seq` return c+#endif++-- | Default value for creating an @UpdateSettings@.+--+-- Since 0.1.0+defaultUpdateSettings :: UpdateSettings ()+defaultUpdateSettings = UpdateSettings+ { updateFreq = 1000000+ , updateSpawnThreshold = 3+ , updateAction = return ()+ }++-- | Settings to control how values are updated.+--+-- This should be constructed using @defaultUpdateSettings@ and record+-- update syntax, e.g.:+--+-- @+-- let set = defaultUpdateSettings { updateAction = getCurrentTime }+-- @+--+-- Since 0.1.0+data UpdateSettings a = UpdateSettings+ { updateFreq :: Int+ -- ^ Microseconds between update calls. Same considerations as+ -- @threadDelay@ apply.+ --+ -- Default: 1 second (1000000)+ --+ -- Since 0.1.0+ , updateSpawnThreshold :: Int+ -- ^ How many times the data must be requested before we decide to+ -- spawn a dedicated thread.+ --+ -- Default: 3+ --+ -- Since 0.1.0+ , updateAction :: IO a+ -- ^ Action to be performed to get the current value.+ --+ -- Default: does nothing.+ --+ -- Since 0.1.0+ }++data Status a = AutoUpdated+ !a+ {-# UNPACK #-} !Int+ -- Number of times used since last updated.+ {-# UNPACK #-} !ThreadId+ -- Worker thread.+ | ManualUpdates+ {-# UNPACK #-} !Int+ -- Number of times used since we started/switched+ -- off manual updates.++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread.+--+-- Since 0.1.0+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate (UpdateSettings !f !t !a) = do+ istatus <- newIORef $ ManualUpdates 0+ return $! getCurrent f t a istatus++data Action a = Return a | Manual | Spawn++data Replaced = Replaced deriving (Show, Typeable)+instance Exception Replaced++-- | Get the current value, either fed from an auto-update thread, or+-- computed manually in the current thread.+--+-- Since 0.1.0+getCurrent :: Int -- ^ frequency+ -> Int -- ^ spawn threshold+ -> IO a -- ^ internal update action+ -> IORef (Status a) -- ^ mutable state+ -> IO a+getCurrent freq spawnThreshold update istatus = do+ ea <- atomicModifyIORef' istatus increment+ case ea of+ Return a -> return a+ Manual -> update+ Spawn -> do+ a <- update+ tid <- forkIO $ spawn freq update istatus+ join $ atomicModifyIORef' istatus $ turnToAuto a tid+ return a+ where+ increment (AutoUpdated a cnt tid) = (AutoUpdated a (succ cnt) tid, Return a)+ increment (ManualUpdates i) = (ManualUpdates (succ i), act)+ where+ act = if i > spawnThreshold then Spawn else Manual++ -- Normal case.+ turnToAuto a tid (ManualUpdates cnt) = (AutoUpdated a cnt tid+ ,return ())+ -- Race condition: multiple threads were spawned.+ -- So, let's kill the previous one by this thread.+ turnToAuto a tid (AutoUpdated _ cnt old) = (AutoUpdated a cnt tid+ ,throwTo old Replaced)++spawn :: Int -> IO a -> IORef (Status a) -> IO ()+spawn freq update istatus = handle (onErr istatus) $ forever $ do+ threadDelay freq+ a <- update+ join $ atomicModifyIORef' istatus $ turnToManual a+ where+ -- Normal case.+ turnToManual a (AutoUpdated _ cnt tid)+ | cnt >= 1 = (AutoUpdated a 0 tid, return ())+ | otherwise = (ManualUpdates 0, stop)+ -- This case must not happen.+ turnToManual _ (ManualUpdates i) = assert False (ManualUpdates i, stop)++onErr :: IORef (Status a) -> SomeException -> IO ()+onErr istatus ex = case fromException ex of+ Just Replaced -> return ()+ Nothing -> do+ tid <- myThreadId+ atomicModifyIORef' istatus $ clear tid+ throwIO ex+ where+ -- In the race condition described above,+ -- suppose thread A is running, and is killed by thread B.+ -- Thread B then updates the IORef to refer to thread B.+ -- Then thread A's exception handler fires.+ -- We don't want to modify the IORef at all,+ -- since it refers to thread B already.+ -- Solution: only switch back to manual updates+ -- if the IORef is pointing at the current thread.+ clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())+ clear _ status = (status, ())++stop :: IO a+stop = throwIO Replaced
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Michael Snoyman++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,5 @@+See https://github.com/yesodweb/yesod-scaffold/pull/15++Todo:++- Add ThreadId to prevent race condition.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ auto-update.cabal view
@@ -0,0 +1,29 @@+name: auto-update+version: 0.1.0.0+synopsis: Efficiently run periodic, on-demand actions+description:+ 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.+ .+ 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.+homepage: https://github.com/yesodweb/wai+license: MIT+license-file: LICENSE+author: Michael Snoyman+maintainer: michael@snoyman.com+category: Control+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Control.AutoUpdate+ build-depends: base >= 4 && < 5+ default-language: Haskell2010++test-suite spec+ main-is: Spec.hs+ other-modules: Control.AutoUpdateSpec+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ build-depends: base, auto-update, hspec+ default-language: Haskell2010
+ test/Control/AutoUpdateSpec.hs view
@@ -0,0 +1,34 @@+module Control.AutoUpdateSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck+import Data.IORef+import Control.Concurrent (threadDelay)+import Control.Monad (replicateM_, forM_)+import Control.AutoUpdate++spec :: Spec+spec = do+ prop "incrementer" $ \st' -> do+ let st = abs st'+ ref <- newIORef 0+ next <- mkAutoUpdate defaultUpdateSettings+ { updateAction = atomicModifyIORef ref $ \i ->+ let i' = succ i in i' `seq` (i', i')+ , updateSpawnThreshold = st+ , updateFreq = 10000+ }++ forM_ [1..st + 1] $ \i -> do+ j <- next+ j `shouldBe` i++ replicateM_ 50 $ do+ i <- next+ i `shouldBe` st + 2++ threadDelay 60000+ last1 <- readIORef ref+ threadDelay 20000+ last2 <- readIORef ref+ last2 `shouldBe` last1
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}