%  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.


\begin{code}
{-# OPTIONS -fffi -fglasgow-exts #-}
module Exec ( exec, exec_interactive,
              Redirects, Redirect(..),
              ExecException(..)
            ) where

import System
import System.Cmd (rawSystem)
import IO
import Data.Typeable ( Typeable )

#ifndef WIN32

import Control.Exception ( throwDyn, handleJust, userErrors )
import System.Posix.IO ( setFdOption, FdOption(..), stdInput )
import Foreign
import Foreign.C
#include "impossible.h"

withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a
withCStrings strings doit = wcss strings []
    where wcss [] css = withArray0 nullPtr (reverse css) $ \aack -> doit aack
          wcss (s:ss) css = withCString s $ \cstr -> wcss ss (cstr:css)

#endif

{-
   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 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 [String] Redirects String
                     deriving (Typeable,Show)

exec  :: String -> [String] -> Redirects -> IO ExitCode

#ifdef WIN32

{-
  On Windows we call the system function with a command line
  string. The string has the arguments in quotes, and contains
  redirection operators.
-}

exec cmd args (inp,out,err) =
  system $ cmd ++ " " ++ in_quotes_unwords args
           ++ (redirect "<"  inp)
           ++ (redirect ">"  out)
           ++ (redirect "2>" err) -- order is important if err is Stdout
  where redirect op value =
          case value of
            -- FIXME: are all these spaces necessary?
            AsIs      -> ""
            Null      -> " " ++ op ++ " " ++ "NUL"
            File "/dev/null" ->  -- safety catch
                         " " ++ op ++ " " ++ "NUL"
            File fp   -> " " ++ op ++ " \"" ++ fp ++ "\"" -- fp in quotes
            Stdout    -> " " ++ op ++ "&1"

in_quotes_unwords :: [String] -> [Char]
in_quotes_unwords (a:as) = "\""++a++"\" "++ in_quotes_unwords as
in_quotes_unwords [] = ""

#else

{-
  On Unix we create a pipe, fork, use dup2 for redirections (after opening
  relevant files). Then we exec the command in the child. If the exec fails
  the child sends back an error string over the pipe. The parent process waits
  for the child's exit status and also checks if an error was sent on the pipe.
  If any system call returns an error code, we throw an ExecException.
-}

exec cmd args redirs =
  handleJust userErrors
             (throwDyn . ExecException cmd args redirs) $ do
    (readFd,writeFd) <- pipe
    fval <- c_fork
    case fval of
      -1 -> do err <- errno
               c_close readFd
               c_close writeFd
               failWithErrno "fork" err
      0 -> do -- child
        c_close readFd 
        let sendError::String->IO a -- does not return
            sendError str = do
                writeFullString writeFd str
                c_close writeFd
                exitWith (ExitFailure 127)
        bracket (return ())
                (\()->sendError "uncaught exception") $ \()-> do
          handleJust userErrors sendError $
            withRedirects redirs $
              execvp_no_vtalarm cmd args
              -- execvp either doesn't return or throws a userError.
              -- If it doesn't return, writeFd will be closed
              -- automatically by the OS.
      pid -> do -- parent
        c_close writeFd
        -- read what the child process sent on the pipe
        pipestr <- readUntilEof readFd
        c_close readFd
        ecode <- smart_wait pid
        case pipestr of
          "" -> -- child process succeeded in executing command
              return $ if ecode == 0 then ExitSuccess
                       else ExitFailure (fromIntegral ecode)
          _ ->  -- child sent an error through the pipe
              fail pipestr

withRedirects :: Redirects -> IO a -> IO a
withRedirects (inp,out,err) job =
  do redirect 0 inp
     redirect 1 out
     redirect 2 err  -- order is important if err is Stdout
     job
  where redirect _      AsIs       = return () -- a no-op
        redirect std_fd Null       = redirect std_fd (File "/dev/null")
        redirect std_fd Stdout     = do dup2 1 std_fd
                                        return ()
        redirect std_fd (File fp)  = do file_fd <- open_like std_fd fp
                                        dup2 file_fd std_fd
                                        return ()
        open_like 0 = open_read
        open_like 1 = open_write
        open_like 2 = open_write
        open_like _ = impossible

{-
  Consume a whole stream from an fd and return a string.
  Throws a userError if any system call fails.
-}

readUntilEof :: CInt -> IO String
readUntilEof fd =
    allocaBytes 1000 $ \ buffer ->
        let loop :: IO String
            loop = do
              readResult <- retryWhileEINTR $ c_read fd buffer 1000
              case compare readResult 0 of
                EQ -> return "" -- 0 means end of file
                LT -> failWithErrno "read from pipe" (fromIntegral readResult)
                GT -> do str <- peekCStringLen (buffer,fromIntegral readResult)
                         rest <- loop
                         return (str++rest)
        in loop

{-
  Writes a string to an fd, making sure that the whole
  string is sent.
  NB. It does NOT throw any exception if a system call
  fails.
-}

writeFullString :: CInt -> String -> IO ()
writeFullString fd str =
    withCStringLen str $ \ (c_str,len) ->
        let loop::Int->IO ()
            loop pos =
                case compare pos len of
                  EQ -> return ()
                  LT -> do
                    result <-
                        retryWhileEINTR $
                        c_write fd (plusPtr c_str pos) (fromIntegral (len-pos))
                    case compare result 0 of
                      LT -> return () -- failed to write for some reason... but
                                      -- there is no point in throwing an error.
                      GT -> loop (pos+fromIntegral result)
                      EQ -> loop pos
                  GT -> impossible
        in loop 0



{-
  Wrappers around lowlevel C functions so that they throw
  userErrors in case of failure and are retried if they
  return EINTR.
-}

execvp_no_vtalarm::String->[String]->IO a
execvp_no_vtalarm cmd args =
    do withCString cmd $ \c_cmd ->
         withCStrings (cmd:args) $ \c_args ->
           c_execvp_no_vtalarm c_cmd c_args
       -- execvp only returns if there was an error
       -- so we throw an exception
       err <- errno
       failWithErrno "execvp" err

open_read::String->IO CInt
open_read fname =
    withCString fname (failOnMinus1 "open_read" . c_open_read)

open_write::String->IO CInt
open_write fname =
    withCString fname (failOnMinus1 "open_write" . c_open_write)

dup2::CInt->CInt->IO CInt
dup2 oldfd newfd = failOnMinus1 "dup2" $ c_dup2 oldfd newfd


pipe::IO (CInt,CInt) -- (readFd, writeFd)
pipe =
    allocaArray 2 $ \ fileDescs -> do
      failOnMinus1 "pipe" $ c_pipe fileDescs
      [readFd,writeFd] <- peekArray 2 fileDescs
      return (readFd,writeFd)


strerror::CInt->IO String
strerror err = do
    cstr <- c_strerror err
    case () of
      _ | cstr == nullPtr -> return "unknown error"
        | otherwise -> peekCString cstr


{-
  Helper used to wrap C routines that return -1 on failure.
  If there is a failure, it fails with a string derived from errno,
  unless errno==EINTR in which case the C call will be retried.
-}

failOnMinus1::String->IO CInt->IO CInt
failOnMinus1 context job = do
  result <- job
  case result of
    -1 -> do e <- errno
             case () of
               _ | Errno e == eOK -> impossible
                 | Errno e == eINTR -> failOnMinus1 context job
                 | otherwise -> failWithErrno context e
    _ -> return result



{-
  Helper used to wrap C routines like read and write that
  return EINTR when interrupted by signals.
-}

retryWhileEINTR :: Integral a => IO a -> IO a
retryWhileEINTR job = do
  result <- job
  case () of
    _ | Errno (fromIntegral result) == eINTR -> retryWhileEINTR job
      | otherwise -> return result


{-
  Looks up the error string for a particular
  errno and throws a userError containing it.
-}

failWithErrno :: String -> CInt -> IO a
failWithErrno context err = do
  str <- strerror err
  fail (context++": "++str)


foreign import ccall unsafe "static compat.h smart_wait" smart_wait
    :: Int -> IO Int
foreign import ccall unsafe "static compat.h open_read" c_open_read
    :: CString -> IO CInt
foreign import ccall unsafe "static compat.h open_write" c_open_write
    :: CString -> IO CInt
foreign import ccall unsafe
    "static compat.h execvp_no_vtalarm" c_execvp_no_vtalarm
    :: CString -> Ptr CString -> IO Int
foreign import ccall unsafe "static unistd.h fork" c_fork
    :: IO Int
foreign import ccall unsafe "static unistd.h dup2" c_dup2
    :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "static unistd.h pipe" c_pipe
    :: Ptr CInt -> IO CInt
foreign import ccall unsafe "static unistd.h close" c_close
    :: CInt->IO CInt
foreign import ccall unsafe "static unistd.h read" c_read
    :: CInt->Ptr a->CSize->IO CSize
foreign import ccall unsafe "static unistd.h write" c_write
    :: CInt->Ptr a->CSize->IO CSize
foreign import ccall unsafe "static compat.h get_errno" errno
    :: IO CInt
foreign import ccall unsafe "static errno.h strerror" c_strerror
    :: CInt -> IO CString

#endif

exec_interactive :: String -> [String] -> IO ExitCode

#ifndef WIN32

exec_interactive arg0 args = do
  stdin `seq` return ()
  bracket (setFdOption stdInput NonBlockingRead False)
          (\_ -> setFdOption stdInput NonBlockingRead True)
          (\_ -> rawSystem arg0 args)

#else

exec_interactive = rawSystem

#endif
\end{code}


