From 6281a1fc2f38e262abe1522fb8f4f85959713b41 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 28 Apr 2013 14:13:18 +0100 Subject: [PATCH 2/2] When possible, give more useful exceptions from rawSystem and friends --- System/Process.hs | 76 +++++++++------------- System/Process/Internals.hs | 146 +++++++++++++++++++++++++++++++++++-------- cbits/runProcess.c | 4 +- include/runProcess.h | 3 +- 4 files changed, 153 insertions(+), 76 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 96c621d..485efbe 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE InterruptibleFFI #-} #endif ----------------------------------------------------------------------------- @@ -337,19 +336,11 @@ waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess ph = do - p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_) + p_ <- waitForProcessHelper ph case p_ of - ClosedHandle e -> return e - OpenHandle h -> do - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) - alloca $ \pret -> do - throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) - modifyProcessHandle ph $ \p_' -> - case p_' of - ClosedHandle e -> return (p_',e) - OpenHandle ph' -> resolveProcessHandle pret ph' + ClosedHandle e -> return e + IOErrorHandle e -> throwIO e + OpenHandle {} -> error "waitForProcess: Can't happen: OpenHandle" -- ----------------------------------------------------------------------------- -- @@ -602,8 +593,9 @@ terminateProcess :: ProcessHandle -> IO () terminateProcess ph = do withProcessHandle ph $ \p_ -> case p_ of - ClosedHandle _ -> return () - OpenHandle h -> do + ClosedHandle _ -> return () + IOErrorHandle _ -> return () + OpenHandle h _ _ -> do throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h return () -- does not close the handle, we might want to try terminating it @@ -625,8 +617,9 @@ interruptProcessGroupOf interruptProcessGroupOf ph = do withProcessHandle ph $ \p_ -> do case p_ of - ClosedHandle _ -> return () - OpenHandle h -> do + ClosedHandle _ -> return () + IOErrorHandle _ -> return () + OpenHandle h _ _ -> do #if mingw32_HOST_OS pid <- getProcessId h generateConsoleCtrlEvent cTRL_BREAK_EVENT pid @@ -658,30 +651,25 @@ when the process died as the result of a signal. getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) getProcessExitCode ph = do - modifyProcessHandle ph $ \p_ -> - case p_ of - ClosedHandle e -> return (p_, Just e) - OpenHandle h -> - alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ - c_getProcessExitCode h pExitCode - if res == 0 - then return (p_, Nothing) - else do (p_', ec) <- resolveProcessHandle pExitCode h - return (p_', Just ec) - --- ---------------------------------------------------------------------------- --- Helper - -resolveProcessHandle :: Ptr CInt -> PHANDLE - -> IO (ProcessHandle__, ExitCode) -resolveProcessHandle pExitCode ph - = do closePHANDLE ph - code <- peek pExitCode - let e = if code == 0 - then ExitSuccess - else ExitFailure (fromIntegral code) - return (ClosedHandle e, e) + p_ <- modifyProcessHandle ph $ \p_ -> do + p_' <- case p_ of + ClosedHandle {} -> return p_ + IOErrorHandle {} -> return p_ + OpenHandle h process_flag process_errno -> + alloca $ \pExitCode -> do + res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ + c_getProcessExitCode h pExitCode + if res == 0 + then return p_ + else do p_' <- resolveProcessHandle pExitCode h + process_flag + process_errno + return p_' + return (p_', p_') + case p_ of + OpenHandle {} -> return Nothing + ClosedHandle e -> return (Just e) + IOErrorHandle e -> throwIO e -- ---------------------------------------------------------------------------- -- Interface to C bits @@ -696,11 +684,5 @@ foreign import ccall unsafe "getProcessExitCode" :: PHANDLE -> Ptr CInt -> IO CInt - -foreign import ccall interruptible "waitForProcess" -- NB. safe - can block - c_waitForProcess - :: PHANDLE - -> Ptr CInt - -> IO CInt #endif /* !__HUGS__ */ diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 2d605c1..05a14d8 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK hide #-} #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE InterruptibleFFI #-} #endif ----------------------------------------------------------------------------- @@ -24,6 +25,7 @@ module System.Process.Internals ( ProcessHandle(..), ProcessHandle__(..), PHANDLE, closePHANDLE, mkProcessHandle, modifyProcessHandle, withProcessHandle, + waitForProcessHelper, resolveProcessHandle, #ifdef __GLASGOW_HASKELL__ CreateProcess(..), CmdSpec(..), StdStream(..), @@ -54,8 +56,9 @@ import System.IO import System.IO.Unsafe import Control.Concurrent import Control.Exception +import Control.Monad import Foreign.C -import Foreign +import Foreign hiding (void) # ifdef __GLASGOW_HASKELL__ @@ -66,7 +69,7 @@ import qualified GHC.IO.FD as FD import GHC.IO.Device import GHC.IO.Handle.FD import GHC.IO.Handle.Internals -import GHC.IO.Handle.Types +import GHC.IO.Handle.Types (Handle__(..)) import System.IO.Error import Data.Typeable #if defined(mingw32_HOST_OS) @@ -104,14 +107,30 @@ import System.FilePath termination: they all return a 'ProcessHandle' which may be used to wait for the process later. -} -data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode +data ProcessHandle__ = OpenHandle PHANDLE (Ptr CInt) (Ptr CInt) + | ClosedHandle ExitCode + | IOErrorHandle IOError newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__) modifyProcessHandle :: ProcessHandle -> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a -modifyProcessHandle (ProcessHandle m) io = modifyMVar m io +modifyProcessHandle (ProcessHandle m) io = + mask $ \restore -> do + modifyMVarMasked m $ \p_ -> do + r@(p_', _) <- restore (io p_) + -- If we just changed from an OpenHandle to something else, we + -- need to free process_flag and process_errno. + case p_ of + OpenHandle _ process_flag process_errno -> + case p_' of + OpenHandle {} -> return () + _ -> do + free process_flag + free process_errno + _ -> return () + return r withProcessHandle :: ProcessHandle @@ -123,10 +142,22 @@ withProcessHandle (ProcessHandle m) io = withMVar m io type PHANDLE = CPid -mkProcessHandle :: PHANDLE -> IO ProcessHandle -mkProcessHandle p = do - m <- newMVar (OpenHandle p) - return (ProcessHandle m) +mkProcessHandle :: PHANDLE -> Ptr CInt -> Ptr CInt -> IO ProcessHandle +mkProcessHandle p process_flag process_errno = do + m <- newMVar (OpenHandle p process_flag process_errno) + let ph = ProcessHandle m + -- We need to free process_flag and process_errno even if the + -- process handle is never waited for, but just left to the GCer. + -- But we can't free them before the process has terminated, or + -- the forked process might write to them. We therefore need to + -- first wait for the proces to terminate, and then free them, + -- which happily is precisely what waitForProcess does. We + -- ignore any IO exceptions that may arise while we do that. + finalise = void (waitForProcessHelper ph) + `catchIOError` \_ -> return () + void $ mkWeakMVar m finalise + return ph + closePHANDLE :: PHANDLE -> IO () closePHANDLE _ = return () @@ -162,6 +193,59 @@ foreign import stdcall unsafe "CloseHandle" #endif #endif /* !__HUGS__ */ +waitForProcessHelper + :: ProcessHandle + -> IO ProcessHandle__ +waitForProcessHelper ph = do + p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_) + case p_ of + ClosedHandle {} -> return p_ + IOErrorHandle {} -> return p_ + OpenHandle h _ _ -> do + -- don't hold the MVar while we call c_waitForProcess... + -- (XXX but there's a small race window here during which another + -- thread could close the handle or call waitForProcess) + alloca $ \pret -> do + throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) + modifyProcessHandle ph $ \p_' -> do + p_'' <- case p_' of + ClosedHandle {} -> return p_' + IOErrorHandle {} -> return p_' + OpenHandle ph' process_flag process_errno -> + resolveProcessHandle pret ph' + process_flag process_errno + return (p_'', p_'') + +foreign import ccall interruptible "waitForProcess" -- NB. safe - can block + c_waitForProcess + :: PHANDLE + -> Ptr CInt + -> IO CInt + +-- ---------------------------------------------------------------------------- +-- Helper + +resolveProcessHandle :: Ptr CInt -> PHANDLE -> Ptr CInt -> Ptr CInt + -> IO ProcessHandle__ +resolveProcessHandle pExitCode ph process_flag process_errno + = do closePHANDLE ph + flag <- peek process_flag + case flag of + 0 -> + do code <- peek pExitCode + let e = if code == 0 + then ExitSuccess + else ExitFailure (fromIntegral code) + return (ClosedHandle e) + 1 -> + do errno <- peek process_errno + let e = errnoToIOError "resolveProcessHandle" + (Errno errno) + Nothing Nothing + return (IOErrorHandle e) + _ -> + error ("resolveProcessHandle: Can't happen: Flag " ++ show flag) + -- ---------------------------------------------------------------------------- data CreateProcess = CreateProcess{ @@ -238,25 +322,31 @@ runGenProcess_ fun CreateProcess{ cmdspec = cmdsp, Nothing -> (0, 0) Just hand -> (1, hand) - -- runInteractiveProcess() blocks signals around the fork(). - -- Since blocking/unblocking of signals is a global state - -- operation, we better ensure mutual exclusion of calls to - -- runInteractiveProcess(). - proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> - throwErrnoIfMinus1 fun $ - c_runInteractiveProcess pargs pWorkDir pEnv - fdin fdout fderr - pfdStdInput pfdStdOutput pfdStdError - set_int inthand set_quit quithand - ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) - .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) - - hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode - hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode - hndStdError <- mbPipe mb_stderr pfdStdError ReadMode - - ph <- mkProcessHandle proc_handle - return (hndStdInput, hndStdOutput, hndStdError, ph) + bracketOnError malloc free $ \process_flag -> + bracketOnError malloc free $ \process_errno -> + mask $ \restore -> do + poke process_flag 0 + + -- runInteractiveProcess() blocks signals around the fork(). + -- Since blocking/unblocking of signals is a global state + -- operation, we better ensure mutual exclusion of calls to + -- runInteractiveProcess(). + proc_handle <- restore $ withMVar runInteractiveProcess_lock $ \_ -> + throwErrnoIfMinus1 fun $ + c_runInteractiveProcess pargs pWorkDir pEnv + fdin fdout fderr + pfdStdInput pfdStdOutput pfdStdError + set_int inthand set_quit quithand + ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) + .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) + process_flag process_errno + + hndStdInput <- restore $ mbPipe mb_stdin pfdStdInput WriteMode + hndStdOutput <- restore $ mbPipe mb_stdout pfdStdOutput ReadMode + hndStdError <- restore $ mbPipe mb_stderr pfdStdError ReadMode + + ph <- mkProcessHandle proc_handle process_flag process_errno + return (hndStdInput, hndStdOutput, hndStdError, ph) {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar () @@ -278,6 +368,8 @@ foreign import ccall unsafe "runInteractiveProcess" -> CInt -- non-zero: set child's SIGQUIT handler -> CLong -- SIGQUIT handler -> CInt -- flags + -> Ptr CInt + -> Ptr CInt -> IO PHANDLE #endif /* __GLASGOW_HASKELL__ */ diff --git a/cbits/runProcess.c b/cbits/runProcess.c index eed9638..61d4652 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -42,7 +42,7 @@ runInteractiveProcess (char *const args[], int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, int set_inthandler, long inthandler, int set_quithandler, long quithandler, - int flags) + int flags, int *process_flag, int *process_errno) { int close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); int pid; @@ -198,6 +198,8 @@ runInteractiveProcess (char *const args[], execvp(args[0], args); } } + *process_flag = 1; + *process_errno = errno; _exit(127); default: diff --git a/include/runProcess.h b/include/runProcess.h index f435c59..4828c03 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -62,7 +62,8 @@ extern ProcHandle runInteractiveProcess( char *const args[], int *pfdStdError, int set_inthandler, long inthandler, int set_quithandler, long quithandler, - int flags); + int flags, + int *process_flag, int *process_errno); #else -- 1.7.10.4