timeout.hs

#!/usr/bin/env runhaskell

import Data.List
import Data.IORef
import System.Exit
import System.Process
import System.Environment
import System.Posix.Unistd

import Control.Concurrent

polltime = 10 -- in seconds

main = 
    do args <- getArgs 
       -- A flag for completion:
       ref <- newIORef False
       case args of 
        time:rest -> 
	    let timeout = read time 
		cmd = concat $ intersperse " " rest
            in
	    do putStrLn$ "++ Running command with timeout = "++ show timeout ++" seconds:\n  " ++ cmd
	       pid <- runCommand  cmd

               sync <- newEmptyMVar

	       let loop acc = 
		    if acc > (timeout :: Int)
		    then do putStrLn$ "\nERROR: TIMED OUT!"
			    putMVar sync (ExitFailure 88)
	 		    --exitWith (ExitFailure 88)
                            
	 	    else do sleep polltime
			    x <- getProcessExitCode pid
			    case x of 
	                      Nothing -> do putStrLn$ "++ Polling, approximately "++ 
						      show (acc+polltime) ++" seconds have elapsed..."
				            loop (acc+polltime)
			      Just code -> putMVar sync code
	       let poll_thread = loop 0
	       let wait_thread = 
                        do code <- waitForProcess pid
			   writeIORef ref True
			   putStrLn$ "++ Command completed without timing out, exit code: "++ show code
			   putMVar sync code
	       forkIO wait_thread
	       forkIO poll_thread
	       final <- readMVar sync
	       exitWith final