autoupdate

gistfile1.hs

{-# LANGUAGE DeriveDataTypeable #-}
-- FIXME: should we replace Data with System?
module Data.AutoUpdate where

import Control.Applicative ((<$>))
import Data.IORef
import Control.Concurrent (threadDelay, forkIO, ThreadId,  myThreadId)
import Control.Monad (forever)
import Control.Exception (throwTo, Exception, handle, fromException, throwIO, assert, SomeException)
import Data.Typeable (Typeable)

----------------------------------------------------------------

data UpdateSettings a = UpdateSettings
    { updateFreq :: !Int
    , updateSpawnThreshold :: !Int
    , updateAction :: !(IO a)
    }

data Status a = AutoUpdated !a
                            !Int -- ^ # of manual update during updateFreq
                            !ThreadId
              | ManualUpdates !Int  -- ^ # of manual update

data AutoUpdate a = AutoUpdate
    { auSettings :: !(UpdateSettings a)
    , auStatus :: !(IORef (Status a))
    }

data Action a = Return a | Manual | Spawn

data Replaced = Replaced deriving (Show, Typeable)
instance Exception Replaced

----------------------------------------------------------------

mkAutoUpdate :: UpdateSettings a -> IO (AutoUpdate a)
mkAutoUpdate settings = AutoUpdate settings <$> newIORef (ManualUpdates 0)

getCurrent :: AutoUpdate a -> IO a
getCurrent au@(AutoUpdate (UpdateSettings _ spawnThreshold action) istatus) = do
    ea <- atomicModifyIORef' istatus increment
    case ea of
        Return a -> return a
        Manual   -> action
        Spawn    -> do
            a <- action
            tid <- forkIO $ spawn au
            doit <- atomicModifyIORef' istatus (turnToAuto a tid)
            doit
            return a
  where
    increment (AutoUpdated a cnt tid) = (AutoUpdated a (succ cnt) tid, Return a)
    increment (ManualUpdates i)       = (ManualUpdates (succ i),       act)
      where
        -- FIXME: i is just a counter. we cannot tell how frequent
        -- getCurrent is called.
        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 oldtid)
        = (AutoUpdated a cnt tid, throwTo oldtid Replaced)

----------------------------------------------------------------

spawn :: AutoUpdate a -> IO ()
spawn (AutoUpdate (UpdateSettings freq _ action) istatus) = handle (onErr istatus) $ forever $ do
    threadDelay freq
    myid <- myThreadId
    a <- action
    doit <- atomicModifyIORef' istatus $ trunToManual myid a
    doit
  where
    -- Normal case.
    trunToManual myid a (AutoUpdated _ cnt tid)
      | myid /= tid                       = assert False (ManualUpdates 0, stop)
      | cnt >= 1                          = (AutoUpdated a 0 tid, return ())
      | otherwise                         = (ManualUpdates 0, stop)
    -- This case must not happen.
    trunToManual _    _ (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
        myid <- myThreadId
        atomicModifyIORef istatus $ clear myid
        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 myid (AutoUpdated _ _ tid)
      | myid == tid                  = (ManualUpdates 0, ())
    clear _    status                = (status, ())

stop :: IO a
stop = throwIO Replaced