[Haskell-cafe] Optimizing a high-traffic network architecture

[Joel Reymont]

On Dec 14, 2005, at 7:48 PM, Tomasz Zielonka wrote:

> You don't have to check "every few seconds". You can determine
> exactly how much you have to sleep - just check the timeout/event with
> the lowest ClockTime.

Something like this? Comments are welcome!

It would be cool to not have to export and call initTimers somehow.

---
{-# OPTIONS_GHC -fglasgow-exts -fno-cse #-}
module Timer
(
initTimers,
startTimer,
stopTimer
)
where

import qualified Data.Map as M
import System.Time
import System.IO.Unsafe
import Control.Exception
import Control.Concurrent

--- Map timer name and kick-off time to action
type Timers = M.Map (ClockTime, String) (IO ())

timeout :: Int
timeout = 5000000 -- 1 second

{-# NOINLINE timers #-}
timers :: MVar Timers
timers = unsafePerformIO $ newMVar M.empty

--- Call this first
initTimers :: IO ()
initTimers =
     do forkIO $ block checkTimers
        return ()

--- Not sure if this is the most efficient way to do it
startTimer :: String -> Int -> (IO ()) -> IO ()
startTimer name delay io =
     do stopTimer name
        now <- getClockTime
        let plus = TimeDiff 0 0 0 0 0 delay 0
            future = addToClockTime plus now
        block $ do t <- takeMVar timers
                   putMVar timers $ M.insert (future, name) io t

--- The filter expression is kind of long...
stopTimer :: String -> IO ()
stopTimer name =
     block $ do t <- takeMVar timers
                putMVar timers $
                        M.filterWithKey (\(_, k) _ -> k /= name) t

--- Tried to take care of exceptions here
--- but the code looks kind of ugly
checkTimers :: IO ()
checkTimers =
     do t <- takeMVar timers
        case M.size t of
          -- no timers
          0 -> do putMVar timers t
                  unblock $ threadDelay timeout
          -- some timers
          n -> do let (key@(time, name), io) = M.findMin t
                  now <- getClockTime
                  if (time <= now)
                     then do putMVar timers $ M.delete key t
                             unblock io
                     else do putMVar timers t
                             unblock $ threadDelay timeout
        checkTimers


--
http://wagerlabs.com/