process-listlike-0.10: src/System/Process/ListLike/ReadNoThreads.hs
{-# LANGUAGE MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-}
{-# OPTIONS -Wwarn -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
-- | This is an alternative version of the module
-- "System.Process.ListLike.Read" that doesn't use forkIO. I don't
-- know of any advantages, I'm just including it because it is derived
-- from old code I had developed, it is kinda badass, and maybe
-- someone has a use for it.
--
-- Function to run a process and return a lazy list of chunks from
-- standard output, standard error, and at the end of the list an
-- object indicating the process result code. If neither output
-- handle is ready for reading the process sleeps and tries again,
-- with the sleep intervals increasing from 8 microseconds to a
-- maximum of 0.1 seconds.
module System.Process.ListLike.ReadNoThreads
( ListLikeIOPlus(..)
, readCreateProcess
, readCreateProcessWithExitCode
, readProcessWithExitCode
) where
import Control.Applicative ((<$>), (<*>), pure)
import Control.Concurrent (threadDelay)
import Control.Exception (catch, mask, onException, try)
import Data.ListLike (ListLike(length, null), ListLikeIO(hGetNonBlocking))
import Data.Maybe (mapMaybe)
import Data.Monoid (Monoid(mempty), (<>), mconcat)
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (encodeUtf8)
import qualified GHC.IO.Exception as E
import Prelude hiding (length, null)
import System.Exit (ExitCode)
import System.Process (ProcessHandle, CreateProcess(..), waitForProcess, proc, createProcess, StdStream(CreatePipe), terminateProcess)
import System.IO (Handle, hReady, hClose)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Process.ListLike.Classes (ProcessOutput(..), ListLikeLazyIO(..))
import System.Process.ListLike.Instances ()
-- For the ListLikeIOPlus instance
import qualified Data.ByteString.Lazy as L
import Data.Word (Word8)
-- | For the unthreaded implementation we need a more powerful
-- ListLikeLazyIO class.
class ListLikeLazyIO a c => ListLikeIOPlus a c where
hPutNonBlocking :: Handle -> a -> IO a
chunks :: a -> [a]
instance ListLikeIOPlus L.ByteString Word8 where
hPutNonBlocking = L.hPutNonBlocking
chunks = Prelude.map (L.fromChunks . (: [])) . L.toChunks
instance ListLikeIOPlus LT.Text Char where
hPutNonBlocking h text = L.hPutNonBlocking h (encodeUtf8 text) >> return text
chunks = map (LT.fromChunks . (: [])) . LT.toChunks
bufSize = 65536 -- maximum chunk size
uSecs = 8 -- minimum wait time, doubles each time nothing is ready
maxUSecs = 100000 -- maximum wait time (microseconds)
readCreateProcess :: forall a b c. (ListLikeIOPlus a c, ProcessOutput a b) => CreateProcess -> a -> IO b
readCreateProcess p input = mask $ \ restore -> do
(Just inh, Just outh, Just errh, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe})
-- setModes input hs
-- The uses of unsafeInterleaveIO here and below are required to
-- keep the output from blocking waiting for process exit.
onException
(restore $ (<>) <$> pure (pidf pid)
<*> (unsafeInterleaveIO $ elements pid (chunks input, Just inh, [(outf, outh), (errf, errh)], Nothing)))
(do terminateProcess pid; hClose inh; hClose outh; hClose errh;
waitForProcess pid)
where
elements :: ProcessHandle -> ([a], Maybe Handle, [(a -> b, Handle)], Maybe b) -> IO b
-- EOF on both output descriptors, get exit code. It can be
-- argued that the list will always contain exactly one exit
-- code if traversed to its end, because the only case of
-- elements that does not recurse is the one that adds a Result,
-- and nowhere else is a Result added. However, the process
-- doing the traversing might die before that end is reached.
elements pid tuple@(_, _, [], elems) =
do result <- try (waitForProcess pid)
case result of
Left exn -> (<>) <$> pure (maybe mempty id elems <> intf exn) <*> elements pid tuple
Right code -> pure (maybe mempty id elems <> codef code)
-- The available output has been processed, send input and read
-- from the ready handles
elements pid tuple@(_, _, _, Nothing) =
do result <- try (ready uSecs tuple)
case result of
Left exn -> (<>) <$> pure (intf exn) <*> elements pid tuple
Right tuple' -> elements pid tuple'
-- Add some output to the result value
elements pid (input, inh, pairs, Just elems) =
(<>) <$> pure elems
<*> (unsafeInterleaveIO $ elements pid (input, inh, pairs, Nothing))
-- A quick fix for the issue where hWaitForInput has actually started
-- raising the isEOFError exception in ghc 6.10.
data Readyness = Ready | Unready | EndOfFile deriving Eq
hReady' :: Handle -> IO Readyness
hReady' h = (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) `catch` (\ (e :: IOError) ->
case E.ioe_type e of
E.EOF -> return EndOfFile
_ -> error (show e))
-- | Wait until at least one handle is ready and then write input or
-- read output. Note that there is no way to check whether the input
-- handle is ready except to try to write to it and see if any bytes
-- are accepted. If no input is accepted, or the input handle is
-- already closed, and none of the output descriptors are ready for
-- reading the function sleeps and tries again.
ready :: (ListLikeIOPlus a c, ProcessOutput a b) =>
Int -> ([a], Maybe Handle, [(a -> b, Handle)], Maybe b)
-> IO ([a], Maybe Handle, [(a -> b, Handle)], Maybe b)
ready waitUSecs (input, inh, pairs, elems) =
do
anyReady <- mapM (hReady' . snd) pairs
case (input, inh, anyReady) of
-- Input exhausted, close the input handle.
([], Just handle, _) | all (== Unready) anyReady ->
do hClose handle
ready waitUSecs ([], Nothing, pairs, elems)
-- Input handle closed and there are no ready output handles,
-- wait a bit
([], Nothing, _) | all (== Unready) anyReady ->
do threadDelay waitUSecs
--ePut0 ("Slept " ++ show uSecs ++ " microseconds\n")
ready (min maxUSecs (2 * waitUSecs)) (input, inh, pairs, elems)
-- Input is available and there are no ready output handles
(input : etc, Just handle, _)
-- Discard a zero byte input
| all (== Unready) anyReady && null input -> ready waitUSecs (etc, inh, pairs, elems)
-- Send some input to the process
| all (== Unready) anyReady ->
do input' <- hPutNonBlocking handle input
case null input' of
-- Input buffer is full too, sleep.
True -> do threadDelay uSecs
ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, pairs, elems)
-- We wrote some input, discard it and continue
False -> return (input' : etc, Just handle, pairs, elems)
-- One or both output handles are ready, try to read from them
_ ->
do allOutputs <- mapM (\ ((f, h), r) -> nextOut h r f) (zip pairs anyReady)
let newPairs = mapMaybe (\ ((_, mh), (f, _)) -> maybe Nothing (\ h -> Just (f, h)) mh) (zip allOutputs pairs)
return (input, inh, newPairs, elems <> mconcat (map fst allOutputs))
-- | Return the next output element and the updated handle
-- from a handle which is assumed ready.
nextOut :: (ListLikeIO a c, ProcessOutput a b) => Handle -> Readyness -> (a -> b) -> IO (Maybe b, Maybe Handle)
nextOut _ EndOfFile _ = return (Nothing, Nothing) -- Handle is closed
nextOut handle Unready _ = return (Nothing, Just handle) -- Handle is not ready
nextOut handle Ready constructor = -- Perform a read
do
a <- hGetNonBlocking handle bufSize
case length a of
-- A zero length read, unlike a zero length write, always
-- means EOF.
0 -> do hClose handle
return (Nothing, Nothing)
-- Got some input
_n -> return (Just (constructor a), Just handle)
readCreateProcessWithExitCode :: (ListLikeIOPlus a c) => CreateProcess -> a -> IO (ExitCode, a, a)
readCreateProcessWithExitCode p input = readCreateProcess p input
readProcessWithExitCode :: (ListLikeIOPlus a c) => FilePath -> [String] -> a -> IO (ExitCode, a, a)
readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input