----------------------------------------------------------------------------------------- {-| Module : Process Copyright : (c) Daan Leijen 2003 License : wxWindows Maintainer : wxhaskell-devel@lists.sourceforge.net Stability : provisional Portability : portable Process and stream wrappers. -} ----------------------------------------------------------------------------------------- module Graphics.UI.WXCore.Process ( -- * Process OnReceive, OnEndProcess , processExecAsyncTimed, processExecAsync -- * Streams , StreamStatus(..) , streamBaseStatus -- * Blocking IO , inputStreamGetContents , inputStreamGetContentsN , inputStreamGetLine , inputStreamGetString , inputStreamGetChar , outputStreamPutString -- * Non-blocking IO , inputStreamGetLineNoWait , inputStreamGetStringNoWait , inputStreamGetCharNoWait , outputStreamPutStringNoWait ) where import System.IO.Unsafe( unsafeInterleaveIO ) import Graphics.UI.WXCore.WxcTypes( ptrCast ) import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Events import Foreign import Foreign.Ptr import Foreign.Storable import Foreign.C.String import Foreign.C.Types -- | Write a string to an output stream, potentially blocking -- until all output has been written. outputStreamPutString :: OutputStream a -> String -> IO () outputStreamPutString outputStream s = withCString s $ \cstr -> write cstr (length s) where write cstr n = do outputStreamWrite outputStream cstr n m <- outputStreamLastWrite outputStream if (m < n && m > 0 {- prevent infinite loop -} ) then write (advancePtr cstr m) (n - m) else return () -- | Write a string to an output stream, returning the -- number of bytes actually written. outputStreamPutStringNoWait :: OutputStream a -> String -> IO Int outputStreamPutStringNoWait outputStream s = withCString s $ \cstr -> do outputStreamWrite outputStream cstr (length s) outputStreamLastWrite outputStream -- | @inputStreamGetLineNoWait stream n@ reads a line of at most @n@ characters from the -- input stream in a non-blocking way. The function does automatic end-of-line -- conversion. If the line ends with @\\n@, an entire line -- has been read, otherwise, either the maximum has been reached, or no more -- input was available. inputStreamGetLineNoWait :: InputStream a -> Int -> IO String inputStreamGetLineNoWait inputStream max = read "" 0 where read acc n = if n >= max then return (reverse acc) else do mbc <- inputStreamGetCharNoWait inputStream case mbc of Nothing -> return (reverse acc) Just '\n' -> return (reverse ('\n':acc)) Just '\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream case mbc2 of Just c2 | c2 /= '\n' -> do inputStreamUngetch inputStream c2 return () _ -> return () return (reverse ('\n':acc)) Just c -> read (c:acc) (n+1) -- | @inputStreamGetStringNoWait stream n@ reads a line of at most @n@ characters from the -- input stream in a non-blocking way. inputStreamGetStringNoWait :: InputStream a -> Int -> IO String inputStreamGetStringNoWait input max = read "" 0 where read acc n = if ( n >= max ) then return (reverse acc) else do mbc <- inputStreamGetCharNoWait input case mbc of Nothing -> return (reverse acc) Just c -> read (c:acc) (n+1) -- | Read a single character from the input, returning @Nothing@ if no input -- was available (using 'inputStreamCanRead'). inputStreamGetCharNoWait :: InputStream a -> IO (Maybe Char) inputStreamGetCharNoWait input = do canRead <- inputStreamCanRead input if canRead then do c <- inputStreamGetC input return (Just c) else return Nothing -- | @inputStreamGetLine s n@ reads a line of at most @n@ characters from the -- input stream (potentially waiting for input). The function does automatic end-of-line -- conversion. If the line ends with @\\n@, an entire line -- has been read, otherwise, either the maximum has been reached, or no more -- input was available. inputStreamGetLine :: InputStream a -> Int -> IO String inputStreamGetLine inputStream max = read "" 0 where read acc n = if n >= max then return (reverse acc) else do c <- inputStreamGetChar inputStream case c of '\n' -> return (reverse ('\n':acc)) '\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream case mbc2 of Just c2 | c2 /= '\n' -> do inputStreamUngetch inputStream c2 return () _ -> return () return (reverse ('\n':acc)) _ -> read (c:acc) (n+1) -- | Read a single character from the input. (equals 'inputStreamGetC') inputStreamGetChar :: InputStream a -> IO Char inputStreamGetChar input = inputStreamGetC input -- | The expression (@inputStreamGetString n input@) reads a string of maximally -- @n@ characters from @input@. inputStreamGetString :: InputStream a -> Int -> IO String inputStreamGetString inputStream n = allocaBytes (n+1) $ \buffer -> do inputStreamRead inputStream buffer n nread <- inputStreamLastRead inputStream mapM (peekChar buffer) [0..nread-1] where peekChar :: Ptr CChar -> Int -> IO Char peekChar p ofs = do cchar <- peekElemOff p ofs return (castCCharToChar cchar) -- | Get the entire contents of an input stream. The content -- is returned as a lazy stream (like 'hGetContents'). inputStreamGetContents :: InputStream a -> IO String inputStreamGetContents inputStream = inputStreamGetContentsN inputStream 1 -- | Get the entire contents of an input stream. The content -- is returned as a lazy stream (like 'hGetContents'). The -- contents are returned in lazy /batches/, whose size is -- determined by the first parameter. inputStreamGetContentsN :: InputStream a -> Int -> IO String inputStreamGetContentsN inputStream n = do status <- streamBaseGetLastError inputStream if (status == wxSTREAM_NO_ERROR) then do x <- inputStreamGetString inputStream n xs <- unsafeInterleaveIO (inputStreamGetContentsN inputStream n) return (x ++ xs) else return "" -- | Return the status of the stream streamBaseStatus :: StreamBase a -> IO StreamStatus streamBaseStatus stream = do code <- streamBaseGetLastError stream return (streamStatusFromInt code) -- | Type of input receiver function. type OnReceive = String -> StreamStatus -> IO () -- | Type of end-of-process event handler. Gets the exitcode as its argument. type OnEndProcess = Int -> IO () -- | (@processExecAsyncTimer command processOutputOnEnd onEndProcess onOutput onErrorOutput parent@) starts -- the @command@ asynchronously. The handler @onEndProcess@ is called when the process -- terminates. @onOutput@ receives the output from @stdout@, while @onErrorOutput@ receives -- output from @stderr@. If @processOutputOnEnd@ is 'True', the remaining output of a terminated -- process is processed (calling @onOutput@). The call returns a triple (@send,process,pid@): -- The @send@ function is used to send input to the @stdin@ pipe of the process. The -- process object is returned in @process@ and the process identifier in @pid@. -- -- Note: The method uses idle event timers to process the output channels. On -- many platforms this is uch more thrustworthy and robust than the 'processExecAsync' that -- uses threads (which can cause all kinds of portability problems). processExecAsyncTimed :: Window a -> String -> Bool -> OnEndProcess -> OnReceive -> OnReceive -> IO (String -> IO StreamStatus, Process (), Int) processExecAsyncTimed parent cmd readInputOnEnd onEndProcess onOutput onErrOutput = do process <- processCreateDefault parent idAny processRedirect process pid <- wxcAppExecuteProcess cmd wxEXEC_ASYNC process if (pid == 0) then return (\s -> return StreamEof, objectNull, pid) else do v <- varCreate (Just process) windowOnIdle parent (handleAnyInput v) unregister <- appRegisterIdle 100 -- 10 times a second evtHandlerOnEndProcess parent (handleTerminate v unregister) let send txt = handleSend v txt return (send, process, pid) where maxLine :: Int maxLine = 160 handleSend :: Var (Maybe (Process a)) -> String -> IO StreamStatus handleSend v txt = withProcess v StreamEof $ \process -> do outputPipe <- processGetOutputStream process outputStreamPutString outputPipe txt -- TODO: use idle events to do output non-blocking? streamBaseStatus outputPipe handleAnyInput :: Var (Maybe (Process a)) -> IO Bool handleAnyInput v = withProcess v False $ \process -> do inputPipe <- processGetInputStream process available <- handleInput inputPipe onOutput -- process some input on stdout errorPipe <- processGetErrorStream process handleAllInput errorPipe onErrOutput -- process all input on stderr return available handleAllInput :: InputStream a -> OnReceive -> IO () handleAllInput input onOutput = do available <- handleInput input onOutput if (available) then handleAllInput input onOutput else return () handleInput :: InputStream a -> OnReceive -> IO Bool handleInput input onOutput = do txt <- inputStreamGetLineNoWait input maxLine status <- streamBaseStatus input if null txt then case status of StreamOk -> return False _ -> do onOutput "" status return False else do onOutput txt status return True handleTerminate :: Var (Maybe (Process a)) -> IO () -> Int -> Int -> IO () handleTerminate v unregister pid exitCode = do unregister withProcess v () $ \process -> do varSet v Nothing if (readInputOnEnd) then do inputPipe <- processGetInputStream process handleAllInput inputPipe onOutput -- handle remaining input else return () onEndProcess exitCode processDelete process return () withProcess v x f = do mb <- varGet v case mb of Nothing -> return x Just p -> f p {-# DEPRECATED processExecAsync "Use processExecAsyncTimed instead (if possible)" #-} -- | deprecated: use 'processExecAsyncTimed' instead (if possible). -- (@processExecAsync command bufferSize onEndProcess onOutput onErrorOutput parent@) starts -- the @command@ asynchronously. The handler @onEndProcess@ is called when the process -- terminates. @onOutput@ receives the output from @stdout@, while @onErrorOutput@ receives -- output from @stderr@. The @bufferSize@ determines the intermediate buffer used to -- cache the output from those channels. The calls returns a triple (@send,process,pid@): -- The @send@ function is used to send input to the @stdin@ pipe of the process. The -- process object is returned in @process@ and the process identifier in @pid@. processExecAsync :: Window a -> String -> Int -> OnEndProcess -> OnReceive -> OnReceive -> IO (String -> IO (), Process (), Int) processExecAsync parent command bufferSize onEndProcess onOutput onErrOutput = do process <- processCreateDefault parent idAny processRedirect process pid <- wxcAppExecuteProcess command wxEXEC_ASYNC process if (pid == 0) then return (\s -> return (), objectNull, pid) else do inputPipe <- processGetInputStream process outputPipe <- processGetOutputStream process errorPipe <- processGetErrorStream process evtHandlerOnEndProcess parent (handleOnEndProcess pid process inputPipe outputPipe errorPipe) evtHandlerOnInput parent onOutput inputPipe bufferSize evtHandlerOnInput parent onErrOutput errorPipe bufferSize let send txt = outputStreamPutString outputPipe txt return (send, process, pid) where handleOnEndProcess ourPid process inputPipe outputPipe errorPipe pid exitcode | ourPid == pid = do onEndProcess exitcode processDelete process | otherwise = return ()