module Posixutil.ChildProcess (
ChildProcess,
PosixProcess,
ChildProcessStatus(ChildExited,ChildTerminated),
linemode,
arguments,
appendArguments,
environment,
standarderrors,
challengeResponse,
toolName,
newChildProcess,
sendMsg,
sendMsgRaw,
readMsg,
waitForChildProcess,
)
where
import System.IO
import System.IO.Error as IO
import Foreign.C.String
import System.Exit
import System.Process
import Control.Concurrent
import qualified Control.Exception as Exception
import Util.Computation
import Util.CompileFlags
import Util.Object
import Util.IOExtras
import Util.Debug
import Util.FileNames
import Events.Destructible
import Posixutil.BlockSigPIPE
import Posixutil.ProcessClasses
data PosixProcess =
PosixProcess {
args :: [String],
ppenv :: Maybe [(String, String)],
lmode :: Bool,
includestderr :: Bool,
cresponse :: Maybe (String,String),
toolname :: Maybe String
}
defaultPosixProcess :: PosixProcess
defaultPosixProcess =
PosixProcess {
args = [],
ppenv = Nothing,
lmode = True,
includestderr = True,
cresponse = Nothing,
toolname = Nothing
}
linemode :: Bool -> Config PosixProcess
linemode lm' parms = return parms{lmode = lm'}
arguments :: [String] -> Config PosixProcess
arguments args' parms = return parms{args = args'}
appendArguments :: [String] -> Config PosixProcess
appendArguments args' parms = return parms{args = (args parms) ++ args'}
environment :: [(String,String)] -> Config PosixProcess
environment env' parms = return parms{ppenv = Just env'}
standarderrors :: Bool -> Config PosixProcess
standarderrors err' parms = return parms{includestderr = err'}
challengeResponse :: (String,String) -> Config PosixProcess
challengeResponse cr parms = return parms {cresponse = Just cr}
toolName :: String -> Config PosixProcess
toolName n parms = return parms {toolname = Just n}
data ChildProcess = ChildProcess {
processHandle :: ProcessHandle,
processIn :: Handle,
processOutput :: Chan String,
childObjectID :: ObjectID,
lineMode :: Bool,
toolTitle :: String
}
data ChildProcessStatus = ChildExited ExitCode
| ChildTerminated
deriving (Eq, Ord, Show)
newChildProcess :: FilePath -> [Config PosixProcess] -> IO ChildProcess
newChildProcess filePath configurations =
do
parms <- configure defaultPosixProcess configurations
debug("newChildProcess:")
debug(filePath:(args parms))
blockSigPIPE
(processIn,processOut,processErr,processHandle) <- runInteractiveProcess
filePath (args parms) Nothing (ppenv parms)
childObjectID <- newObject
processOutput <- newChan
let
toolTitle :: String
toolTitle =
case (toolname parms,splitName filePath) of
(Just toolTitle,_) -> toolTitle
(Nothing,(dir,toolTitle)) -> toolTitle
lineMode :: Bool
lineMode = lmode parms
getFn :: Handle -> IO String
getFn = if lineMode then hGetLine else getAvail
monitorHandle :: Handle -> IO ()
monitorHandle handle =
foreverUntil (
do
nextOrEOF <- catchEOF (getFn handle)
case nextOrEOF of
Nothing -> return True
Just line ->
do
debugRead childProcess (line ++ "\n")
writeChan processOutput line
return False
)
reportErrors :: IO ()
reportErrors =
foreverUntil (
do
nextOrEOF <- catchEOF (getFn processErr)
case nextOrEOF of
Nothing -> return True
Just line ->
do
hPutStrLn stderr ("Error from " ++ toolTitle
++ ": " ++ line)
hFlush stderr
return False
)
getAvail :: Handle -> IO String
getAvail handle =
do
c0 <- hGetChar handle
getAvail0 [c0] handle
getAvail0 :: String -> Handle -> IO String
getAvail0 acc handle =
do
ready <- hReady handle
if ready
then
do
c <- hGetChar handle
getAvail0 (c : acc) handle
else
return (reverse acc)
childProcess = ChildProcess {
processHandle = processHandle,
processIn = processIn,
processOutput = processOutput,
childObjectID = childObjectID,
lineMode = lineMode,
toolTitle = toolTitle
}
case cresponse parms of
Nothing -> done
Just (challenge,response) ->
do
sendMsg childProcess challenge
responseLineOrError
<- IO.try (mapM (const (hGetChar processOut))
[1..length response])
case responseLineOrError of
Left excep -> error (
"Starting " ++ toolTitle ++ " got IO error "
++ show excep)
Right line -> if line == response
then
done
else
do
remainder <- getAvail0 [] processOut
error (
"Starting " ++ toolTitle
++ " got unexpected response "
++ line ++ remainder
)
forkIO (monitorHandle processOut)
if includestderr parms
then
forkIO (monitorHandle processErr)
else
forkIO (reportErrors)
return childProcess
sendMsg :: ChildProcess -> String -> IO ()
sendMsg childProcess line =
do
debugWrite childProcess line
let
lineToWrite =
if lineMode childProcess then line ++ recordSep else line
hPutStr (processIn childProcess) lineToWrite
hFlush (processIn childProcess)
sendMsgRaw :: ChildProcess -> CStringLen -> IO ()
sendMsgRaw childProcess (cStrLn@(ptr,len)) =
do
if isDebug
then
do
str <- peekCStringLen cStrLn
debugWrite childProcess str
else
done
hPutBuf (processIn childProcess) ptr len
hFlush (processIn childProcess)
readMsg :: ChildProcess -> IO String
readMsg childProcess = readChan (processOutput childProcess)
waitForChildProcess :: ChildProcess -> IO ChildProcessStatus
waitForChildProcess p =
Exception.catch (waitForChild p)
(\ (_ :: Exception.SomeException) -> return ChildTerminated)
where
waitForChild p = do
exitCode <- waitForProcess (processHandle p)
return (ChildExited exitCode)
debugWrite :: ChildProcess -> String -> IO ()
debugWrite childProcess str =
debugString (toolTitle childProcess++">"++str++"\n")
debugRead :: ChildProcess -> String -> IO ()
debugRead childProcess str =
debugString (toolTitle childProcess++"<"++str++"\n")
instance Object ChildProcess where
objectID = childObjectID
instance Destroyable ChildProcess where
destroy childProcess = terminateProcess (processHandle childProcess)
instance Tool ChildProcess where
getToolStatus childProcess = getProcessExitCode (processHandle childProcess)