Concurrent Haskell Actions with Timeout

Answer 1

Here's the first answer I could come up with. I needed this for a port scanner. o_O Forgot the admin password of my router and wanted to check which ports I had opened on our home server before that I could now repurpose and reuse ^ _ ^" ... This implementation should do the job for the time being.

module Control.Concurrent.Timed (timed) where

import Prelude hiding (take)
import System.IO
import Control.Monad
import System.Process
import System.Timeout
import Control.Concurrent
import System.Environment

timed :: Int → IO a → b → IO (Either b a)
timed max act def = do

  w ← new
  r ← new

  t ← forkIO $ do
    a ← act
    r ≔ Right a
    e ← em w
    case e of
      False → kill =<< take w
      True  → return ()

  s ← forkIO $ do
    (w ≔) =<< mine
    wait max
    e ← em r
    case e of
      True  → do
        kill t
        r ≔ Left def
      False → return ()

  take r

timed_ :: Int → IO a → a → IO a
timed_ max act def = do
  r ← timed max act def
  return $ case r of
    Right a → a
    Left  a → a

(≔) = putMVar
new = newEmptyMVar
wait = threadDelay
em = isEmptyMVar
kill = killThread
mine = myThreadId
take = takeMVar

or just use System.Timeout.timeout -__-"

Answer 2

Implementing your desired timed on top of System.Timeout.timeout is easy:

import System.Timeout (timeout)

timed :: Int -> IO a -> b -> IO (Either b a)
timed us act def = timeout us act >>= return . maybe (Left def) Right

By the way, the common implementation of timeout is closer to this: ($! = seq to try to force evaluation of the returned value in the thread rather than only returning a thunk):

import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import System.IO (hPrint, stderr)

timeout :: Int -> IO a -> IO (Maybe a)
timeout us act = do
    mvar <- newEmptyMVar
    tid1 <- forkIO $ (putMVar mvar . Just $!) =<< act
    tid2 <- forkIO $ threadDelay us >> putMVar mvar Nothing
    res <- takeMVar mvar
    killThread (maybe tid1 (const tid2) res) `catch` hPrint stderr
    return res

The implementation of System.Timeout.timeout in the libraries is a little more complex, handling more exceptional cases.

import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)
import Control.Exception   (Exception, handleJust, throwTo, bracket)
import Data.Typeable
import Data.Unique         (Unique, newUnique)

data Timeout = Timeout Unique deriving Eq
timeoutTc :: TyCon
timeoutTc = mkTyCon "Timeout"
instance Typeable Timeout where { typeOf _ = mkTyConApp timeoutTc [] }
instance Show Timeout where
    show _ = "<<timeout>>"
instance Exception Timeout

timeout n f
    | n <  0    = fmap Just f
    | n == 0    = return Nothing
    | otherwise = do
        pid <- myThreadId
        ex  <- fmap Timeout newUnique
        handleJust (\e -> if e == ex then Just () else Nothing)
                   (\_ -> return Nothing)
                   (bracket (forkIO (threadDelay n >> throwTo pid ex))
                            (killThread)
                            (\_ -> fmap Just f))