{- |
Module : ./Interfaces/Process.hs
Description : A process interface for communication with other programs
Copyright : (c) Ewaryst Schulz, DFKI Bremen 2009
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Ewaryst.Schulz@dfki.de
Stability : provisional
Portability : non-portable (various -fglasgow-exts extensions)
Interface for communication with other processes
-}
module Interfaces.Process where
import Control.Monad (liftM, when)
import Control.Monad.Trans (MonadIO (..))
import Control.Monad.State (MonadState (..))
import Common.IO (catchIOException)
import Data.Time
import Data.Maybe
import qualified System.Process as SP
import System.Exit
import System.IO
import Common.IOS
{- ----------------------------------------------------------------------
ReadState, controlled reading from a handle
---------------------------------------------------------------------- -}
type DTime = NominalDiffTime
type Time = UTCTime
data IntelligentReadState = IRS { timeout :: DTime -- ^ total timeout
, started :: Time -- ^ start timestamp
, updated :: Time -- ^ last update stamp
, readtime :: Time -- ^ stamp of last read
, hasread :: Bool -- ^ got data
, waitForRead :: Bool -- ^
, waittimeInp :: Int -- ^ same as waitForInp
} deriving Show
data TimeConfig = TimeConfig { waitForInp :: Int
-- ^ How many milliseconds waiting for next data
, startTimeout :: DTime
-- ^ Give the application some time to come up
, cleanTimeout :: DTime
-- ^
} deriving Show
defaultConfig :: TimeConfig
defaultConfig = TimeConfig { waitForInp = 1
, startTimeout = 0.7
, cleanTimeout = 0.001 }
zeroTime :: Time
zeroTime = UTCTime { utctDay = ModifiedJulianDay { toModifiedJulianDay = 0 }
, utctDayTime = 0 } -- 17.11.1858 00:00:00
initIRS :: Int -> DTime -> Bool -> IO IntelligentReadState
initIRS w t b = do
ts <- getCurrentTime
return $ IRS t ts ts zeroTime False b w
{- |
This class provides an interface to control the output retrieval from an
output handler (in the code of getOutput' you can see this control in action).
-}
class ReadState a where
-- | For updating the ReadState, you may want to set new timestamps, etc.
increment :: a -- ^ the ReadState
-> Bool -- ^ a flag for "got data"
-> IO a {- ^ the updated readstate
A predicate to tell when to abort a read-try, usally when some
timeout has passed -}
abort :: a -> Bool
-- | Wait-time for new input
waitInp :: a -- ^ the ReadState
-> Int -- ^ The milliseconds to wait for new input on the handle
{- | Aborts the read attempt if one of the following holds:
1. the timeout is up
(= last update timestamp - start timestamp >= timeout)
2. between last RS-update and last read with data more than 10% of
timeout passed, AND
some data was already read OR the waitForRead flag is not set
This decision-tree is the reason why we call this ReadState 'Intelligent'
-}
instance ReadState IntelligentReadState where
increment irs ngd =
do
ts <- getCurrentTime
return $ if ngd then irs { updated = ts, readtime = ts, hasread = ngd}
else irs { updated = ts }
abort (IRS to st lus slr gd b _) =
to <= diffUTCTime lus st
|| ((not b || gd)
-- TODO: experiment with the 10 percent!
&& let tr = diffUTCTime lus slr in tr > 0 && to / tr < 10)
waitInp = waittimeInp
getOutput :: (ReadState a) => Handle -> a -> IO String
getOutput hdl rs = do
s <- getOutput' rs hdl ""
return $ reverse s
{- builds the string in the wrong order
tail-recursive function shouldn't make stack problems -}
getOutput' :: (ReadState a) => a -> Handle -> String -> IO String
getOutput' rs hdl s = do
b <- if abort rs then return Nothing {- timeout gone
eventually error on eof so abort -}
else catchIOException Nothing
$ liftM Just $ hWaitForInput hdl $ waitInp rs
case b of Nothing -> return s
Just b' ->
do
ns <- if b' then liftM (: s) $ hGetChar hdl else return s
nrs <- increment rs b'
getOutput' nrs hdl ns
{- | From given Time a ReadState is created and the output is fetched using
getOutput -}
getOutp :: Handle -> Int -> DTime -> IO String
getOutp hdl w t = initIRS w t True >>= getOutput hdl
{- ----------------------------------------------------------------------
A Command Interface using the read state
---------------------------------------------------------------------- -}
{- | This is just a type to hold the information returned by
data CommandState = CS { inp :: Handle, outp :: Handle, err :: Handle
, pid :: SP.ProcessHandle, verbosity :: Int
, tc :: TimeConfig }
-- | The IO State-Monad with state CommandState
type Command = IOS CommandState
-- | initialize the connection by running the given command string
start :: String -- ^ shell string to run the program
-> Int -- ^ Verbosity level
-> Maybe TimeConfig
-> IO CommandState
start shcmd v mTc = do
when (v > 0) $ putStrLn $ "Running " ++ shcmd ++ " ..."
(i, o, e, p) <- SP.runInteractiveCommand shcmd
let cs = CS i o e p v $ fromMaybe defaultConfig mTc
verbMessageIO cs 3 "start: Setting buffer modes"
-- configure the handles
mapM_ (`hSetBinaryMode` False) [i, o, e]
mapM_ (`hSetBuffering` NoBuffering) [o, e]
hSetBuffering i LineBuffering
-- clear all output from the output pipe (TIME: wait 300 milliseconds)
verbMessageIO cs 3 "start: Clearing connection output."
x <- getOutp o (waitForInp $ tc cs) $ startTimeout $ tc cs
verbMessageIO cs 4 $ "start: Received\n--------------\n" ++ x
++ "\n--------------"
return cs
-- | Just read output from the connection waiting at most Time
readOutput :: DTime -> Command String
readOutput t = do
s <- get
liftIO $ getOutp (outp s) (waitForInp $ tc s) t
-- | Just read error output from the connection waiting at most Time
readErr :: DTime -> Command String
readErr t = do
s <- get
liftIO $ getOutp (err s) (waitForInp $ tc s) t
-- | Send some String and don't wait for response
send :: String -> Command ()
send str = do
s <- get
verbMessage s 2 $ "send: Sending " ++ str
liftIO $ hPutStrLn (inp s) str
-- | Send some String and wait Time for response
call :: DTime -- ^ Waits this time until abort call (Use float for seconds)
-> String -- ^ Send this string over the connection
-> Command String -- ^ Response
call t str = do
s <- get
-- first clear all output from the output pipe (wait 50 milliseconds)
verbMessage s 3 "call: Clearing connection output."
x <- liftIO $ getOutp (outp s) (waitForInp $ tc s) $ cleanTimeout $ tc s
verbMessage s 4 $ "\n--------------\n" ++ x ++ "\n--------------"
verbMessage s 2 $ "call: Sending " ++ str
liftIO $ hPutStrLn (inp s) str
res <- liftIO $ getOutp (outp s) (waitForInp $ tc s) t
verbMessage s 2 $ "call: Received " ++ res
return res
verbMessageIO :: CommandState -> Int -> String -> IO String
verbMessageIO cs v s =
if verbosity cs >= v then putStrLn s >> return s else return ""
verbMessage :: CommandState -> Int -> String -> Command String
verbMessage cs v s = liftIO $ verbMessageIO cs v s
{- | Send some exit command if there is one to close the connection.
This is the best one, but may be blocked by the application. -}
close :: Maybe String -> Command (Maybe ExitCode)
close str = do
s <- get
case str of Nothing -> do
verbMessage s 3 "close: No exit command"
return ()
Just excmd -> do
verbMessage s 2 $ "close: sending exit command: " ++ excmd
liftIO $ hPutStrLn (inp s) excmd
-- TODO: find out how to get the process id from the process handle
verbMessage s 3 "close: waiting for process to terminate"
e <- liftIO $ SP.waitForProcess $ pid s
verbMessage s 2 $ "close: process exited with code " ++ show e
return $ Just e
{-
-- Close variants:
-- | Send some exit command if there is one to close the connection
-- , and in addition terminate after wait
close2 :: Maybe String -> Command (Maybe ExitCode)
close2 str = do
s <- get
case str of Nothing -> do
verbMessage s 3 "close: No exit command"
return ()
Just excmd -> do
verbMessage s 2 $ "close: sending exit command: " ++ excmd
liftIO $ hPutStrLn (inp s) excmd
-- TODO: find out how to get the process id from the process handle
verbMessage s 3 $ "close: waiting for process to terminate"
e <- liftIO $ SP.waitForProcess $ pid s
verbMessage s 2 $ "close: process exited with code " ++ show e
verbMessage s 2 $ "close: forcing termination..."
liftIO $ SP.terminateProcess $ pid s
return $ Just e
-- | Send some exit command if there is one to close the connection
-- , but do not wait
close1 :: Maybe String -> Command (Maybe ExitCode)
close1 str = do
s <- get
case str of Nothing -> do
verbMessage s 3 "close: No exit command"
return ()
Just excmd -> do
verbMessage s 2 $ "close: sending exit command: " ++ excmd
liftIO $ hPutStrLn (inp s) excmd
-- TODO: find out how to get the process id from the process handle
verbMessage s 3 $ "close: waiting for process to terminate"
mE <- liftIO $ SP.getProcessExitCode $ pid s
case mE of
Just e -> do
verbMessage s 2 $ "close: process exited with code " ++ show e
return ()
Nothing -> do
verbMessage s 2 $ "close: process did not terminate in time, "
++ "forcing termination..."
liftIO $ SP.terminateProcess $ pid s
return mE
-}