%  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 #-}
module Exec ( exec, exec_interactive,
              Redirects, Redirect(..),
            ) where

import System
import System.Cmd (rawSystem)
import IO

#ifndef WIN32

import System.Posix.IO ( setFdOption, FdOption(..), stdInput )
import Foreign
import Foreign.C
import Monad ( liftM )
#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

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 fork, use dup2 for redirections (after opening
  relevant files). Then we exec the command in the child, and wait
  for its exit status in the parent.
-}

exec cmd args redirs = do
  fval <- c_fork
  case fval of
     -1  -> return $ ExitFailure $ 1
     0   -> -- child
            withRedirects redirs $
            withCString cmd $ \c_cmd ->
            withCStrings (cmd:args) $ \c_args -> do
                -- execvp only returns if there is an error:
                ExitFailure `liftM` execvp_no_vtalarm c_cmd c_args
     pid -> -- parent
            do ecode <- smart_wait pid
               if ecode == 0 then return ExitSuccess
                             else return $ ExitFailure ecode

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     = c_dup2 1 std_fd >> return ()
        redirect std_fd (File fp)  = withCString fp $ \c_fp -> do
                                        file_fd <- open_like std_fd c_fp
                                        c_dup2 file_fd std_fd
                                        return ()
        open_like 0 = open_read
        open_like 1 = open_write
        open_like 2 = open_write
        open_like _ = impossible


foreign import ccall unsafe "static unistd.h dup2" c_dup2
    :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "static compat.h smart_wait" smart_wait
    :: Int -> IO Int
foreign import ccall unsafe "static compat.h open_read" open_read
    :: CString -> IO CInt
foreign import ccall unsafe "static compat.h open_write" open_write
    :: CString -> IO CInt
foreign import ccall unsafe "static unistd.h fork" c_fork
    :: IO Int
foreign import ccall unsafe
    "static compat.h execvp_no_vtalarm" execvp_no_vtalarm
    :: CString -> Ptr CString -> IO Int

#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}


