{- |

Module : $Header$

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

System.Process.runInteractiveCommand -}

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

-}