% Copyright (C) 2003 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \begin{code} {-# OPTIONS -fffi -fglasgow-exts #-} module Exec ( exec, exec_interactive, Redirects, Redirect(..), ExecException(..) ) where import System import System.Cmd (rawSystem) import IO import Data.Typeable ( Typeable ) #ifndef WIN32 import Control.Exception ( throwDyn, handleJust, userErrors ) import System.Posix.IO ( setFdOption, FdOption(..), stdInput ) import Foreign import Foreign.C #include "impossible.h" withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a withCStrings strings doit = wcss strings [] where wcss [] css = withArray0 nullPtr (reverse css) $ \aack -> doit aack wcss (s:ss) css = withCString s $ \cstr -> wcss ss (cstr:css) #endif {- A redirection is a three-tuple of values (in, out, err). The most common values are: AsIs don't change it Null /dev/null on Unix, NUL on Windows File open a file for reading or writing There is also the value Stdout, which is only meaningful for redirection of errors, and is performed AFTER stdout is redirected so that output and errors mix together. StdIn and StdErr could be added as well if they are useful. NOTE: Lots of care must be taken when redirecting stdin, stdout and stderr to one of EACH OTHER, since the ORDER in which they are changed have a significant effect on the result. -} type Redirects = (Redirect, Redirect, Redirect) data Redirect = AsIs | Null | File FilePath | Stdout deriving Show {- ExecException is thrown by exec if any system call fails, for example because the executable we're trying to run doesn't exist. -} -- ExecException cmd args redirecs errorDesc data ExecException = ExecException String [String] Redirects String deriving (Typeable,Show) exec :: String -> [String] -> Redirects -> IO ExitCode #ifdef WIN32 {- On Windows we call the system function with a command line string. The string has the arguments in quotes, and contains redirection operators. -} exec cmd args (inp,out,err) = system $ cmd ++ " " ++ in_quotes_unwords args ++ (redirect "<" inp) ++ (redirect ">" out) ++ (redirect "2>" err) -- order is important if err is Stdout where redirect op value = case value of -- FIXME: are all these spaces necessary? AsIs -> "" Null -> " " ++ op ++ " " ++ "NUL" File "/dev/null" -> -- safety catch " " ++ op ++ " " ++ "NUL" File fp -> " " ++ op ++ " \"" ++ fp ++ "\"" -- fp in quotes Stdout -> " " ++ op ++ "&1" in_quotes_unwords :: [String] -> [Char] in_quotes_unwords (a:as) = "\""++a++"\" "++ in_quotes_unwords as in_quotes_unwords [] = "" #else {- On Unix we create a pipe, fork, use dup2 for redirections (after opening relevant files). Then we exec the command in the child. If the exec fails the child sends back an error string over the pipe. The parent process waits for the child's exit status and also checks if an error was sent on the pipe. If any system call returns an error code, we throw an ExecException. -} exec cmd args redirs = handleJust userErrors (throwDyn . ExecException cmd args redirs) $ do (readFd,writeFd) <- pipe fval <- c_fork case fval of -1 -> do err <- errno c_close readFd c_close writeFd failWithErrno "fork" err 0 -> do -- child c_close readFd let sendError::String->IO a -- does not return sendError str = do writeFullString writeFd str c_close writeFd exitWith (ExitFailure 127) bracket (return ()) (\()->sendError "uncaught exception") $ \()-> do handleJust userErrors sendError $ withRedirects redirs $ execvp_no_vtalarm cmd args -- execvp either doesn't return or throws a userError. -- If it doesn't return, writeFd will be closed -- automatically by the OS. pid -> do -- parent c_close writeFd -- read what the child process sent on the pipe pipestr <- readUntilEof readFd c_close readFd ecode <- smart_wait pid case pipestr of "" -> -- child process succeeded in executing command return $ if ecode == 0 then ExitSuccess else ExitFailure (fromIntegral ecode) _ -> -- child sent an error through the pipe fail pipestr withRedirects :: Redirects -> IO a -> IO a withRedirects (inp,out,err) job = do redirect 0 inp redirect 1 out redirect 2 err -- order is important if err is Stdout job where redirect _ AsIs = return () -- a no-op redirect std_fd Null = redirect std_fd (File "/dev/null") redirect std_fd Stdout = do dup2 1 std_fd return () redirect std_fd (File fp) = do file_fd <- open_like std_fd fp dup2 file_fd std_fd return () open_like 0 = open_read open_like 1 = open_write open_like 2 = open_write open_like _ = impossible {- Consume a whole stream from an fd and return a string. Throws a userError if any system call fails. -} readUntilEof :: CInt -> IO String readUntilEof fd = allocaBytes 1000 $ \ buffer -> let loop :: IO String loop = do readResult <- retryWhileEINTR $ c_read fd buffer 1000 case compare readResult 0 of EQ -> return "" -- 0 means end of file LT -> failWithErrno "read from pipe" (fromIntegral readResult) GT -> do str <- peekCStringLen (buffer,fromIntegral readResult) rest <- loop return (str++rest) in loop {- Writes a string to an fd, making sure that the whole string is sent. NB. It does NOT throw any exception if a system call fails. -} writeFullString :: CInt -> String -> IO () writeFullString fd str = withCStringLen str $ \ (c_str,len) -> let loop::Int->IO () loop pos = case compare pos len of EQ -> return () LT -> do result <- retryWhileEINTR $ c_write fd (plusPtr c_str pos) (fromIntegral (len-pos)) case compare result 0 of LT -> return () -- failed to write for some reason... but -- there is no point in throwing an error. GT -> loop (pos+fromIntegral result) EQ -> loop pos GT -> impossible in loop 0 {- Wrappers around lowlevel C functions so that they throw userErrors in case of failure and are retried if they return EINTR. -} execvp_no_vtalarm::String->[String]->IO a execvp_no_vtalarm cmd args = do withCString cmd $ \c_cmd -> withCStrings (cmd:args) $ \c_args -> c_execvp_no_vtalarm c_cmd c_args -- execvp only returns if there was an error -- so we throw an exception err <- errno failWithErrno "execvp" err open_read::String->IO CInt open_read fname = withCString fname (failOnMinus1 "open_read" . c_open_read) open_write::String->IO CInt open_write fname = withCString fname (failOnMinus1 "open_write" . c_open_write) dup2::CInt->CInt->IO CInt dup2 oldfd newfd = failOnMinus1 "dup2" $ c_dup2 oldfd newfd pipe::IO (CInt,CInt) -- (readFd, writeFd) pipe = allocaArray 2 $ \ fileDescs -> do failOnMinus1 "pipe" $ c_pipe fileDescs [readFd,writeFd] <- peekArray 2 fileDescs return (readFd,writeFd) strerror::CInt->IO String strerror err = do cstr <- c_strerror err case () of _ | cstr == nullPtr -> return "unknown error" | otherwise -> peekCString cstr {- Helper used to wrap C routines that return -1 on failure. If there is a failure, it fails with a string derived from errno, unless errno==EINTR in which case the C call will be retried. -} failOnMinus1::String->IO CInt->IO CInt failOnMinus1 context job = do result <- job case result of -1 -> do e <- errno case () of _ | Errno e == eOK -> impossible | Errno e == eINTR -> failOnMinus1 context job | otherwise -> failWithErrno context e _ -> return result {- Helper used to wrap C routines like read and write that return EINTR when interrupted by signals. -} retryWhileEINTR :: Integral a => IO a -> IO a retryWhileEINTR job = do result <- job case () of _ | Errno (fromIntegral result) == eINTR -> retryWhileEINTR job | otherwise -> return result {- Looks up the error string for a particular errno and throws a userError containing it. -} failWithErrno :: String -> CInt -> IO a failWithErrno context err = do str <- strerror err fail (context++": "++str) foreign import ccall unsafe "static compat.h smart_wait" smart_wait :: Int -> IO Int foreign import ccall unsafe "static compat.h open_read" c_open_read :: CString -> IO CInt foreign import ccall unsafe "static compat.h open_write" c_open_write :: CString -> IO CInt foreign import ccall unsafe "static compat.h execvp_no_vtalarm" c_execvp_no_vtalarm :: CString -> Ptr CString -> IO Int foreign import ccall unsafe "static unistd.h fork" c_fork :: IO Int foreign import ccall unsafe "static unistd.h dup2" c_dup2 :: CInt -> CInt -> IO CInt foreign import ccall unsafe "static unistd.h pipe" c_pipe :: Ptr CInt -> IO CInt foreign import ccall unsafe "static unistd.h close" c_close :: CInt->IO CInt foreign import ccall unsafe "static unistd.h read" c_read :: CInt->Ptr a->CSize->IO CSize foreign import ccall unsafe "static unistd.h write" c_write :: CInt->Ptr a->CSize->IO CSize foreign import ccall unsafe "static compat.h get_errno" errno :: IO CInt foreign import ccall unsafe "static errno.h strerror" c_strerror :: CInt -> IO CString #endif exec_interactive :: String -> [String] -> IO ExitCode #ifndef WIN32 exec_interactive arg0 args = do stdin `seq` return () bracket (setFdOption stdInput NonBlockingRead False) (\_ -> setFdOption stdInput NonBlockingRead True) (\_ -> rawSystem arg0 args) #else exec_interactive = rawSystem #endif \end{code}