module Darcs.Util.Exec
(
exec
, execInteractive
, readInteractiveProcess
, renderExecException
, withoutNonBlock
, Redirects
, Redirect(..)
, ExecException(..)
) where
import Prelude ()
import Darcs.Prelude
#ifndef WIN32
import Control.Exception ( bracket )
import System.Posix.Env ( setEnv, getEnv, unsetEnv )
import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )
#else
import Control.Exception ( catchJust, IOException )
import Data.List ( isInfixOf )
#endif
import GHC.IO.Handle ( hDuplicate )
import Control.Concurrent ( forkIO )
import Control.Concurrent.MVar ( newEmptyMVar, takeMVar, putMVar )
import Control.Exception
( evaluate, bracketOnError, Exception(..), SomeException(..) )
import Data.Typeable ( Typeable, cast )
import System.Process ( system )
import qualified System.Process as P
import System.Exit ( ExitCode (..) )
import System.IO ( IOMode(..), openBinaryFile, stdin, stdout, hGetContents, hClose )
import System.Process ( runProcess, terminateProcess, waitForProcess )
import Darcs.Util.Global ( whenDebugMode )
import Darcs.Util.Progress ( withoutProgress )
type Redirects = (Redirect, Redirect, Redirect)
data Redirect = AsIs
| Null
| File FilePath
| Stdout
deriving Show
data ExecException = ExecException
String
[String]
Redirects
String
deriving (Typeable)
instance Exception ExecException where
toException = SomeException
fromException (SomeException e) = cast e
renderExecException :: ExecException -> String
renderExecException (ExecException cmd args _ msg) =
concat [
"The program \"", unwords (cmd:args),
"\" failed with error: \"",msg,"\"."]
instance Show ExecException where
show = renderExecException
_devNull :: FilePath
#ifdef WIN32
_devNull = "NUL"
#else
_devNull = "/dev/null"
#endif
exec :: String -> [String] -> Redirects -> IO ExitCode
exec cmd args (inp,out,err) = withoutProgress $ do
h_stdin <- redirect inp ReadMode
h_stdout <- redirect out WriteMode
h_stderr <- redirect err WriteMode
withExit127 $ bracketOnError
(do doOptionalDebug
runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)
terminateProcess
waitForProcess
where
doOptionalDebug = whenDebugMode . putStrLn . unwords $
cmd : args ++ ["; #"] ++ map show [inp, out, err]
redirect AsIs _ = return Nothing
redirect Null mode = Just `fmap` openBinaryFile _devNull mode
redirect (File "/dev/null") mode = redirect Null mode
redirect (File f) mode = Just `fmap` openBinaryFile f mode
redirect Stdout _ = Just `fmap` hDuplicate stdout
execInteractive :: String -> String -> IO ExitCode
#ifndef WIN32
execInteractive cmd arg = withoutProgress $ do
let var = "DARCS_ARGUMENT"
stdin `seq` return ()
withoutNonBlock $ bracket
(do oldval <- getEnv var
setEnv var arg True
return oldval)
(\oldval ->
case oldval of
Nothing -> unsetEnv var
Just val -> setEnv var val True)
(\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")
#else
execInteractive cmd arg = withoutProgress $
withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++
cmd ++ " " ++ arg ++
" & exit !errorlevel!"
#endif
withoutNonBlock :: IO a -> IO a
#ifndef WIN32
withoutNonBlock x =
do nb <- queryFdOption stdInput NonBlockingRead
if nb
then bracket
(setFdOption stdInput NonBlockingRead False)
(\_ -> setFdOption stdInput NonBlockingRead True)
(\_ -> x)
else x
#else
withoutNonBlock x = x
#endif
readInteractiveProcess
:: FilePath
-> [String]
-> IO (ExitCode,String)
readInteractiveProcess cmd args = do
inh' <- hDuplicate stdin
outh <- hDuplicate stdout
(_, _, Just errh, pid) <-
P.createProcess (P.proc cmd args){
P.std_in = P.UseHandle inh',
P.std_out = P.UseHandle outh,
P.std_err = P.CreatePipe }
errMVar <- newEmptyMVar
errors <- hGetContents errh
_ <- forkIO $ do
_ <- evaluate (length errors)
putMVar errMVar errors
err <- takeMVar errMVar
hClose errh
ex <- waitForProcess pid
return (ex, err)
withExit127 :: IO ExitCode -> IO ExitCode
#ifdef WIN32
withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)
notFoundError :: IOException -> Maybe ()
notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just ()
notFoundError _ = Nothing
#else
withExit127 = id
#endif