module Exec ( exec, execInteractive,
withoutNonBlock,
Redirects, Redirect(..),
ExecException(..)
) where
import Data.Typeable ( Typeable, cast )
#ifndef WIN32
import Control.Exception.Extensible ( bracket )
import System.Posix.Env ( setEnv, getEnv, unsetEnv )
import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )
import System.IO ( stdin )
#else
import Control.Exception.Extensible ( catchJust, IOException )
import Data.List ( isInfixOf )
#endif
import System.Exit ( ExitCode (..) )
import System.Cmd ( system )
import System.IO ( IOMode(..), openBinaryFile, stdout )
import System.Process ( runProcess, terminateProcess, waitForProcess )
import GHC.Handle ( hDuplicate )
import Control.Exception.Extensible ( bracketOnError, Exception(..), SomeException(..) )
import Darcs.Global ( whenDebugMode )
import 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,Show)
instance Exception ExecException where
toException e = SomeException e
fromException (SomeException e) = cast e
_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 whenDebugMode $ putStrLn $ unwords $ cmd:args ++ ["; #"] ++ map show [inp,out,err]
runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)
(terminateProcess)
(waitForProcess)
where
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 ->
do case oldval of
Nothing -> unsetEnv var
Just val -> setEnv var val True)
(\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")
#else
execInteractive cmd arg = withoutProgress $ do
system $ cmd ++ " " ++ arg
#endif
withoutNonBlock :: IO a -> IO a
#ifndef WIN32
withoutNonBlock x =
do nb <- queryFdOption stdInput NonBlockingRead
if nb
then bracket
(do setFdOption stdInput NonBlockingRead False)
(\_ -> setFdOption stdInput NonBlockingRead True)
(\_ -> x)
else do x
#else
withoutNonBlock x = do x
#endif
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