ghc-dup: 08066879b00ee7e1eca27df1128f73df88392c60

     1: {-# OPTIONS -cpp #-}
     2: module Main where
     3: 
     4: import Control.Concurrent (forkIO, threadDelay)
     5: import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
     6: import Control.Monad
     7: import Control.Exception
     8: import Data.Maybe (isNothing)
     9: import System.Environment (getArgs)
    10: import System.Exit
    11: import System.IO (hPutStrLn, stderr)
    12: 
    13: #if !defined(mingw32_HOST_OS)
    14: import System.Posix hiding (killProcess)
    15: import System.IO.Error hiding (try,catch)
    16: #endif
    17: 
    18: #if defined(mingw32_HOST_OS)
    19: import System.Process
    20: import WinCBindings
    21: import Foreign
    22: import System.Win32.DebugApi
    23: import System.Win32.Types
    24: #endif
    25: 
    26: main :: IO ()
    27: main = do
    28:   args <- getArgs
    29:   case args of
    30:       [secs,cmd] ->
    31:           case reads secs of
    32:           [(secs', "")] -> run secs' cmd
    33:           _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")
    34:       _ -> die ("Bad arguments " ++ show args)
    35: 
    36: die :: String -> IO ()
    37: die msg = do hPutStrLn stderr ("timeout: " ++ msg)
    38:              exitWith (ExitFailure 1)
    39: 
    40: timeoutMsg :: String
    41: timeoutMsg = "Timeout happened...killing process..."
    42: 
    43: run :: Int -> String -> IO ()
    44: #if !defined(mingw32_HOST_OS)
    45: run secs cmd = do
    46:         m <- newEmptyMVar
    47:         mp <- newEmptyMVar
    48:         installHandler sigINT (Catch (putMVar m Nothing)) Nothing
    49:         forkIO $ do threadDelay (secs * 1000000)
    50:                     putMVar m Nothing
    51:         forkIO $ do ei <- try $ do pid <- systemSession cmd
    52:                                    return pid
    53:                     putMVar mp ei
    54:                     case ei of
    55:                        Left _ -> return ()
    56:                        Right pid -> do
    57:                            r <- getProcessStatus True False pid
    58:                            putMVar m r
    59:         ei_pid_ph <- takeMVar mp
    60:         case ei_pid_ph of
    61:             Left e -> do hPutStrLn stderr
    62:                                    ("Timeout:\n" ++ show (e :: IOException))
    63:                          exitWith (ExitFailure 98)
    64:             Right pid -> do
    65:                 r <- takeMVar m
    66:                 case r of
    67:                   Nothing -> do
    68:                         hPutStrLn stderr timeoutMsg
    69:                         killProcess pid
    70:                         exitWith (ExitFailure 99)
    71:                   Just (Exited r) -> exitWith r
    72:                   Just (Terminated s) -> raiseSignal s
    73:                   Just _ -> exitWith (ExitFailure 1)
    74: 
    75: systemSession cmd =
    76:  forkProcess $ do
    77:    createSession
    78:    executeFile "/bin/sh" False ["-c", cmd] Nothing
    79:    -- need to use exec() directly here, rather than something like
    80:    -- System.Process.system, because we are in a forked child and some
    81:    -- pthread libraries get all upset if you start doing certain
    82:    -- things in a forked child of a pthread process, such as forking
    83:    -- more threads.
    84: 
    85: killProcess pid = do
    86:   ignoreIOExceptions (signalProcessGroup sigTERM pid)
    87:   checkReallyDead 10
    88:   where
    89:     checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
    90:     checkReallyDead (n+1) =
    91:       do threadDelay (3*100000) -- 3/10 sec
    92:          m <- tryJust (guard . isDoesNotExistError) $
    93:                  getProcessStatus False False pid
    94:          case m of
    95:             Right Nothing -> return ()
    96:             Left _ -> return ()
    97:             _ -> do
    98:               ignoreIOExceptions (signalProcessGroup sigKILL pid)
    99:               checkReallyDead n
   100: 
   101: ignoreIOExceptions :: IO () -> IO ()
   102: ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ())
   103: 
   104: #else
   105: run secs cmd =
   106:     let escape '\\' = "\\\\"
   107:         escape '"'  = "\\\""
   108:         escape c    = [c]
   109:         cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in
   110:     alloca $ \p_startupinfo ->
   111:     alloca $ \p_pi ->
   112:     withTString cmd' $ \cmd'' ->
   113:     do job <- createJobObjectW nullPtr nullPtr
   114:        let creationflags = 0
   115:        b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
   116:                            creationflags
   117:                            nullPtr nullPtr p_startupinfo p_pi
   118:        unless b $ errorWin "createProcessW"
   119:        pi <- peek p_pi
   120:        assignProcessToJobObject job (piProcess pi)
   121:        resumeThread (piThread pi)
   122: 
   123:        -- The program is now running
   124: 
   125:        let handle = piProcess pi
   126:        let millisecs = secs * 1000
   127:        rc <- waitForSingleObject handle (fromIntegral millisecs)
   128:        if rc == cWAIT_TIMEOUT
   129:            then do hPutStrLn stderr timeoutMsg
   130:                    terminateJobObject job 99
   131:                    exitWith (ExitFailure 99)
   132:            else alloca $ \p_exitCode ->
   133:                 do r <- getExitCodeProcess handle p_exitCode
   134:                    if r then do ec <- peek p_exitCode
   135:                                 let ec' = if ec == 0
   136:                                           then ExitSuccess
   137:                                           else ExitFailure $ fromIntegral ec
   138:                                 exitWith ec'
   139:                         else errorWin "getExitCodeProcess"
   140: #endif
   141: