1 -- Copyright (C) 2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 19 {-# OPTIONS_GHC -fglasgow-exts #-} 20 {-# LANGUAGE CPP, ForeignFunctionInterface #-} 21 -- , DeriveDataTypeable #-} 22 23 module Exec ( exec, exec_interactive, 24 withoutNonBlock, 25 Redirects, Redirect(..), 26 ExecException(..) 27 ) where 28 29 import Data.Typeable ( Typeable ) 30 31 #ifndef WIN32 32 import Control.Exception ( bracket ) 33 import System.Posix.Env ( setEnv, getEnv, unsetEnv ) 34 import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput ) 35 import System.IO ( stdin ) 36 #else 37 import Control.Exception ( catchJust, Exception(IOException) ) 38 import Data.List ( isInfixOf ) 39 #endif 40 41 import System.Exit ( ExitCode (..) ) 42 import System.Cmd ( system ) 43 import System.IO ( IOMode(..), openBinaryFile, stdout ) 44 import System.Process ( runProcess, terminateProcess, waitForProcess ) 45 import GHC.Handle ( hDuplicate ) 46 -- urgh. hDuplicate isn't available from a standard place. 47 import Control.Exception ( bracketOnError ) 48 49 import Darcs.Global ( whenDebugMode ) 50 import Progress ( withoutProgress ) 51 52 {- 53 A redirection is a three-tuple of values (in, out, err). 54 The most common values are: 55 56 AsIs don't change it 57 Null /dev/null on Unix, NUL on Windows 58 File open a file for reading or writing 59 60 There is also the value Stdout, which is only meaningful for 61 redirection of errors, and is performed AFTER stdout is 62 redirected so that output and errors mix together. StdIn and 63 StdErr could be added as well if they are useful. 64 65 NOTE: Lots of care must be taken when redirecting stdin, stdout 66 and stderr to one of EACH OTHER, since the ORDER in which they 67 are changed have a significant effect on the result. 68 -} 69 70 type Redirects = (Redirect, Redirect, Redirect) 71 data Redirect = AsIs | Null | File FilePath 72 | Stdout 73 deriving Show 74 75 {- 76 ExecException is thrown by exec if any system call fails, 77 for example because the executable we're trying to run 78 doesn't exist. 79 -} 80 -- ExecException cmd args redirecs errorDesc 81 data ExecException = ExecException String [String] Redirects String 82 deriving (Typeable,Show) 83 84 85 _dev_null :: FilePath 86 #ifdef WIN32 87 _dev_null = "NUL" 88 #else 89 _dev_null = "/dev/null" 90 #endif 91 92 {- 93 We use System.Process, which does the necessary quoting 94 and redirection for us behind the scenes. 95 -} 96 97 exec :: String -> [String] -> Redirects -> IO ExitCode 98 exec cmd args (inp,out,err) = withoutProgress $ do 99 h_stdin <- redirect inp ReadMode 100 h_stdout <- redirect out WriteMode 101 h_stderr <- redirect err WriteMode 102 -- putStrLn (unwords (cmd:args ++ map show [inp,out,err])) 103 withExit127 $ bracketOnError 104 (do whenDebugMode $ putStrLn $ unwords $ cmd:args ++ ["; #"] ++ map show [inp,out,err] 105 runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr) 106 (terminateProcess) 107 (waitForProcess) 108 where 109 redirect AsIs _ = return Nothing 110 redirect Null mode = Just `fmap` openBinaryFile _dev_null mode 111 redirect (File "/dev/null") mode = redirect Null mode 112 redirect (File f) mode = Just `fmap` openBinaryFile f mode 113 redirect Stdout _ = Just `fmap` hDuplicate stdout 114 -- hDuplicate stdout rather than passing stdout itself, 115 -- because runProcess closes the Handles we pass it. 116 117 exec_interactive :: String -> String -> IO ExitCode 118 119 #ifndef WIN32 120 {- 121 This should handle arbitrary commands interpreted by the shell on Unix since 122 that's what people expect. But we don't want to allow the shell to interpret 123 the argument in any way, so we set an environment variable and call 124 cmd "$DARCS_ARGUMENT" 125 -} 126 exec_interactive cmd arg = withoutProgress $ do 127 let var = "DARCS_ARGUMENT" 128 stdin `seq` return () 129 withoutNonBlock $ bracket 130 (do oldval <- getEnv var 131 setEnv var arg True 132 return oldval) 133 (\oldval -> 134 do case oldval of 135 Nothing -> unsetEnv var 136 Just val -> setEnv var val True) 137 (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"") 138 139 #else 140 141 exec_interactive cmd arg = withoutProgress $ do 142 system $ cmd ++ " " ++ arg 143 #endif 144 145 withoutNonBlock :: IO a -> IO a 146 147 #ifndef WIN32 148 {- 149 Do IO without NonBlockingRead on stdInput. 150 151 This is needed when running unsuspecting external commands with interactive 152 mode - if read from terminal is non-blocking also write to terminal is 153 non-blocking. 154 -} 155 withoutNonBlock x = 156 do nb <- queryFdOption stdInput NonBlockingRead 157 if nb 158 then bracket 159 (do setFdOption stdInput NonBlockingRead False) 160 (\_ -> setFdOption stdInput NonBlockingRead True) 161 (\_ -> x) 162 else do x 163 #else 164 withoutNonBlock x = do x 165 #endif 166 167 {- 168 Ensure that we exit 127 if the thing we are trying to run does not exist 169 (Only needed under Windows) 170 -} 171 withExit127 :: IO ExitCode -> IO ExitCode 172 #ifdef WIN32 173 withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127) 174 175 notFoundError :: Exception -> Maybe () 176 notFoundError (IOException e) | "runProcess: does not exist" `isInfixOf` show e = Just () 177 notFoundError _ = Nothing 178 #else 179 withExit127 = id 180 #endif