src/Exec.lhs

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