-- Copyright (C) 2003 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP #-}

-- |
-- Module      : Darcs.Util.Exec
-- Copyright   : 2003 David Roundy
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable

module Darcs.Util.Exec
    (
      exec
    , execInteractive
    , readInteractiveProcess
    , renderExecException
    , withoutNonBlock
    , Redirects
    , Redirect(..)
    , ExecException(..)
    ) where

import Darcs.Prelude

#ifndef WIN32
import Control.Exception ( bracket )
import Control.Monad ( forM_ )
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 )

{-
   A redirection is a three-tuple of values (in, out, err).
   The most common values are:

     AsIs    don't change it
     Null    /dev/null on Unix, NUL on Windows
     File    open a file for reading or writing

   There is also the value Stdout, which is only meaningful for
   redirection of errors, and is performed AFTER stdout is
   redirected so that output and errors mix together. StdIn and
   StdErr could be added as well if they are useful.

   NOTE: Lots of care must be taken when redirecting stdin, stdout
   and stderr to one of EACH OTHER, since the ORDER in which they
   are changed have a significant effect on the result.
-}

type Redirects = (Redirect, Redirect, Redirect)

data Redirect = AsIs
              | Null
              | File FilePath
              | Stdout
                deriving Int -> Redirect -> ShowS
[Redirect] -> ShowS
Redirect -> String
(Int -> Redirect -> ShowS)
-> (Redirect -> String) -> ([Redirect] -> ShowS) -> Show Redirect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Redirect] -> ShowS
$cshowList :: [Redirect] -> ShowS
show :: Redirect -> String
$cshow :: Redirect -> String
showsPrec :: Int -> Redirect -> ShowS
$cshowsPrec :: Int -> Redirect -> ShowS
Show

{-
  ExecException is thrown by exec if any system call fails,
  for example because the executable we're trying to run
  doesn't exist.
-}
--                   ExecException cmd    args     redirecs  errorDesc
data ExecException = ExecException
                        String     -- cmd
                        [String]   -- args
                        Redirects  -- redirects
                        String     -- errorDesc
                     deriving (Typeable)

instance Exception ExecException where
    toException :: ExecException -> SomeException
toException = ExecException -> SomeException
forall e. Exception e => e -> SomeException
SomeException
    fromException :: SomeException -> Maybe ExecException
fromException (SomeException e
e) = e -> Maybe ExecException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

renderExecException :: ExecException -> String
renderExecException :: ExecException -> String
renderExecException (ExecException String
cmd [String]
args Redirects
_ String
msg) =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
    String
"The program \"", [String] -> String
unwords (String
cmdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args),
    String
"\" failed with error: \"",String
msg,String
"\"."]

instance Show ExecException where
  show :: ExecException -> String
show = ExecException -> String
renderExecException

_devNull :: FilePath
#ifdef WIN32
-- since GHC 8.6, Windows special devices need to be referred to using
-- "device namespace" syntax. See
-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/win32-dlls.html#windows-file-paths
_devNull = "\\\\.\\NUL"
#else
_devNull :: String
_devNull = String
"/dev/null"
#endif

{-
  We use System.Process, which does the necessary quoting
  and redirection for us behind the scenes.
-}
exec  :: String -> [String] -> Redirects -> IO ExitCode
exec :: String -> [String] -> Redirects -> IO ExitCode
exec String
cmd [String]
args (Redirect
inp,Redirect
out,Redirect
err) = IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withoutProgress (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
    Maybe Handle
h_stdin  <- Redirect -> IOMode -> IO (Maybe Handle)
redirect Redirect
inp IOMode
ReadMode
    Maybe Handle
h_stdout <- Redirect -> IOMode -> IO (Maybe Handle)
redirect Redirect
out IOMode
WriteMode
    Maybe Handle
h_stderr <- Redirect -> IOMode -> IO (Maybe Handle)
redirect Redirect
err IOMode
WriteMode
    IO ExitCode -> IO ExitCode
withExit127 (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ IO ProcessHandle
-> (ProcessHandle -> IO ())
-> (ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
      (do IO ()
doOptionalDebug
          String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cmd [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
h_stdin Maybe Handle
h_stdout Maybe Handle
h_stderr)
      ProcessHandle -> IO ()
terminateProcess
      ProcessHandle -> IO ExitCode
waitForProcess
  where
    doOptionalDebug :: IO ()
doOptionalDebug = IO () -> IO ()
whenDebugMode (IO () -> IO ()) -> ([String] -> IO ()) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"; #"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Redirect -> String) -> [Redirect] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Redirect -> String
forall a. Show a => a -> String
show [Redirect
inp, Redirect
out, Redirect
err]
    redirect :: Redirect -> IOMode -> IO (Maybe Handle)
redirect Redirect
AsIs               IOMode
_    = Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
    redirect Redirect
Null               IOMode
mode = Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IOMode -> IO Handle
openBinaryFile String
_devNull IOMode
mode
    redirect (File String
"/dev/null") IOMode
mode = Redirect -> IOMode -> IO (Maybe Handle)
redirect Redirect
Null IOMode
mode
    redirect (File String
f)           IOMode
mode = Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IOMode -> IO Handle
openBinaryFile String
f IOMode
mode
    -- hDuplicate stdout rather than passing stdout itself,
    -- because runProcess closes the Handles we pass it.
    redirect Redirect
Stdout             IOMode
_    = Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO Handle
hDuplicate Handle
stdout

execInteractive :: String -> Maybe String -> IO ExitCode
#ifndef WIN32
{-
This should handle arbitrary commands interpreted by the shell on Unix since
that's what people expect. But we don't want to allow the shell to interpret
the argument in any way, so we set an environment variable and call
cmd "$DARCS_ARGUMENT"
-}
execInteractive :: String -> Maybe String -> IO ExitCode
execInteractive String
cmd Maybe String
mArg = IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withoutProgress (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
    let var :: String
var = String
"DARCS_ARGUMENT"
    Handle
stdin Handle -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withoutNonBlock (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ IO (Maybe String)
-> (Maybe String -> IO ())
-> (Maybe String -> IO ExitCode)
-> IO ExitCode
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (do Maybe String
oldval <- String -> IO (Maybe String)
getEnv String
var
          Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mArg ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
arg ->
            String -> String -> Bool -> IO ()
setEnv String
var String
arg Bool
True
          Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
oldval)
      (\Maybe String
oldval ->
         case Maybe String
oldval of
              Maybe String
Nothing -> String -> IO ()
unsetEnv String
var
              Just String
val -> String -> String -> Bool -> IO ()
setEnv String
var String
val Bool
True)
      (\Maybe String
_ -> IO ExitCode -> IO ExitCode
withExit127 (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String -> IO ExitCode
system (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
cmdString -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> ShowS
forall a b. a -> b -> a
const (String
" \"$"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
varString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\"")) Maybe String
mArg)

#else
-- The `system' function passes commands to execute via cmd.exe (or
-- command.com) it's return value is equivalent to the one returned by the
-- shell. For regular applications - this works correctly resulting in the
-- exit code of the program. However in case of a command/file which can't be
-- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009
-- which on windows is equivalent to ExitFailure 127 from *nix machines.
--
-- Here we force return the exit code of the last cmd.exe action by appending
-- & exit !errorlevel! to the command being executed that way chaining with
-- ortryrunning works correctly.
--
-- SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done
-- correctly on systems where that function is not enabled by default.
--
execInteractive cmd mArg = withoutProgress $
  withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++
                          cmd ++ maybe "" (" " ++) mArg ++
                          " & exit !errorlevel!"
#endif

withoutNonBlock :: IO a -> IO a
#ifndef WIN32
{-
Do IO without NonBlockingRead on stdInput.

This is needed when running unsuspecting external commands with interactive
mode - if read from terminal is non-blocking also write to terminal is
non-blocking.
-}
withoutNonBlock :: IO a -> IO a
withoutNonBlock IO a
x =
    do Bool
nb <- Fd -> FdOption -> IO Bool
queryFdOption Fd
stdInput FdOption
NonBlockingRead
       if Bool
nb
          then IO () -> (() -> IO ()) -> (() -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
                   (Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
stdInput FdOption
NonBlockingRead Bool
False)
                   (\()
_ -> Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
stdInput FdOption
NonBlockingRead Bool
True)
                   (\()
_ -> IO a
x)
          else IO a
x
#else
withoutNonBlock x = x
#endif

readInteractiveProcess
    :: FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
    -> IO (ExitCode,String)      -- ^ exitcode, stderr
readInteractiveProcess :: String -> [String] -> IO (ExitCode, String)
readInteractiveProcess String
cmd [String]
args = do
    Handle
inh' <- Handle -> IO Handle
hDuplicate Handle
stdin
    Handle
outh <- Handle -> IO Handle
hDuplicate Handle
stdout
    (Maybe Handle
_, Maybe Handle
_, Just Handle
errh, ProcessHandle
pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess (String -> [String] -> CreateProcess
P.proc String
cmd [String]
args){
          std_in :: StdStream
P.std_in  = Handle -> StdStream
P.UseHandle Handle
inh',
          std_out :: StdStream
P.std_out = Handle -> StdStream
P.UseHandle Handle
outh,
          std_err :: StdStream
P.std_err = StdStream
P.CreatePipe }
    MVar String
errMVar <- IO (MVar String)
forall a. IO (MVar a)
newEmptyMVar

    String
errors <- Handle -> IO String
hGetContents Handle
errh
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
errors)
      MVar String -> String -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar String
errMVar String
errors

    String
err <- MVar String -> IO String
forall a. MVar a -> IO a
takeMVar MVar String
errMVar
    Handle -> IO ()
hClose Handle
errh

    ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

    (ExitCode, String) -> IO (ExitCode, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, String
err)
  
{-
Ensure that we exit 127 if the thing we are trying to run does not exist
(Only needed under Windows)
-}
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 :: IO ExitCode -> IO ExitCode
withExit127 = IO ExitCode -> IO ExitCode
forall a. a -> a
id
#endif