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