Utils.hs

module Festung.Concurrency.Utils
  ( copyMVar
  , readAnyMVar
  , readMVarTimeout
  , readChanTimeout
  , forkIOForSure
  ) where

import Control.Concurrent
import Control.Monad


-- | Copy (by using readMVar not takeMVar) an MVar into another MVar
copyMVar :: (a -> b) -> MVar a -> MVar b -> IO ()
copyMVar f src dst = putMVar dst =<< fmap f (readMVar src)


-- | Read the first MVar that gets filled.
--
-- If both MVar get filled at the same time, or are already filled, the result of this
-- function is undefined.
readAnyMVar :: MVar a -> MVar b -> IO (Either a b)
readAnyMVar a b = do
    result <- newEmptyMVar
    first  <- forkIO $ copyMVar Left  a result
    second <- forkIO $ copyMVar Right b result

    takeMVar result
        <* mapM_ killThread [first, second]


-- | Read the MVar with timeout
--
-- Try to read the MVar and return @'Nothing' if the MVar doesn't get filled
-- within a certain amount of microseconds.
readMVarTimeout :: Int -> MVar a -> IO (Maybe a)
readMVarTimeout timeout mvar = do
    timeoutMVar   <- newEmptyMVar
    timeoutThread <- forkIO . void $ do threadDelay timeout
                                        tryPutMVar timeoutMVar ()
    result        <- readAnyMVar timeoutMVar mvar
    killThread timeoutThread

    return $ case result of
                 Left () -> Nothing
                 Right e -> Just e


-- | Read the next value from a @'Chan' within a certain time
--
-- Note: If this times out, nothing guarantee that the value hasn't been read
-- from the @'Chan' and discarded.
readChanTimeout :: Int -> Chan a -> IO (Maybe a)
readChanTimeout timeout chan = do
    mvar   <- newEmptyMVar
    reader <- forkIO (putMVar mvar =<< readChan chan)
    readMVarTimeout timeout mvar
        <* killThread reader


-- | Like forkIO but make sure the green thread is started
forkIOForSure :: IO () -> IO ThreadId
forkIOForSure action = do
    mvar <- newEmptyMVar
    forkIO (putMVar mvar () >> action)
        <* readMVar mvar