stm timeout

gistfile1.hs

import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TMVar
import Data.Maybe


stmTimeout :: Int -> IO a -> IO (Maybe a)
stmTimeout timeout action = do
  tOut <- registerDelay timeout
  result <- newEmptyTMVarIO
  workerId <- forkIO $ action >>= atomically . (putTMVar result)
  o <- atomically $ do
            end <- readTVar tOut
            if end then return Nothing
                   else tryTakeTMVar result >>= maybe retry (return . Just)
  when (not $! isJust o) $ killThread workerId `catch` (const $ return ())
  return o