{-# LANGUAGE ForeignFunctionInterface #-}
module StartProcess(startProcess,dup) where
import Control.Monad(when)
import MyForeign(Int32,Addr(..))
import Marshall(CString(..),CInt32,freePtr,newArray,readArray,writeArray,addrOf,nullStr,marshallString)
import Sockets(Socket(..),SocketResponse(..))
import P_IO_data({-Request(..),-}Response(..))
import Utils(swap)

startProcess cmd doIn doOut doErr =
  do inPipe <- optPipe doIn
     outPipe <- optPipe doOut
     errPipe <- optPipe doErr
--     pid <- _ccall_ fork
     pid <- fork
     case pid::Int of
       -1 -> failu "fork" -- use tryP instead
       0 -> do -- child process
	       -- Disable virtual timer, used by the GHC RTS
	       disable_timers
	       optDupIn 0 inPipe
	       optDupOut 1 outPipe
	       optDupOut 2 errPipe
	       binsh <- marshallString "/bin/sh"
	       sh <- marshallString "sh"
	       dashc <- marshallString "-c"
	       ccmd <- marshallString cmd
               argv <- newArray 4
               writeArray argv [sh,dashc,ccmd,nullStr]
	       execv binsh argv
	       --_ccall_ _exit 1
               freePtr argv
	       failu "execv"
       _ -> do -- parent process
	       inS <- optPipeIn inPipe
	       outS <- optPipeOut outPipe
	       errS <- optPipeOut errPipe
	       return $ SocketResponse $ ProcessSockets inS outS errS
  where
    optPipe False = return Nothing
    optPipe True = Just `fmap` newPipe
    newPipe = do pa <- newArray 2
		 ok <- pipe (addrOf (pa::CInt32))
		 [p0,p1] <- readArray pa 2
		 freePtr pa
		 when (ok/=0) $ failu "pipe" -- use tryP instead
		 return (p0,p1)

    optDupIn d = optDupOut d . fmap swap
    optDupOut d = maybe (return ()) (dupOut d)
    dupOut d (p0,p1) = do cclose d
			  dup p1
			  cclose p0
			  cclose p1
			  return ()

    optPipeIn = optPipeS "w" . fmap swap
    optPipeOut = optPipeS "r"
    optPipeS m = maybe (return Nothing) (fmap Just . pipeS m)
    pipeS m (p0,p1) = do cclose p1
			 return $ So (fromEnum p0)


type Fd = Int32

-- New: using file descriptors for socket and file I/O
--getfilep :: Fd -> String -> IO Int
--getfilep fd _mode = return (fromEnum fd)

foreign import ccall "unistd.h" fork :: IO Int
foreign import ccall "unistd.h" execv :: CString -> CString -> IO Int
foreign import ccall "unistd.h" pipe :: Addr -> IO Int
foreign import ccall "unistd.h" dup :: Fd -> IO Fd
foreign import ccall "asyncinput.h" disable_timers :: IO ()

foreign import ccall "unistd.h close" cclose :: Fd -> IO Int32

failu = ioError . userError