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 ()
import qualified Data.ByteString.Lazy as L
import Data.Word (Word8)
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
uSecs = 8
maxUSecs = 100000
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})
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
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)
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'
elements pid (input, inh, pairs, Just elems) =
(<>) <$> pure elems
<*> (unsafeInterleaveIO $ elements pid (input, inh, pairs, Nothing))
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))
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
([], Just handle, _) | all (== Unready) anyReady ->
do hClose handle
ready waitUSecs ([], Nothing, pairs, elems)
([], Nothing, _) | all (== Unready) anyReady ->
do threadDelay waitUSecs
ready (min maxUSecs (2 * waitUSecs)) (input, inh, pairs, elems)
(input : etc, Just handle, _)
| all (== Unready) anyReady && null input -> ready waitUSecs (etc, inh, pairs, elems)
| all (== Unready) anyReady ->
do input' <- hPutNonBlocking handle input
case null input' of
True -> do threadDelay uSecs
ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, pairs, elems)
False -> return (input' : etc, Just handle, pairs, elems)
_ ->
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))
nextOut :: (ListLikeIO a c, ProcessOutput a b) => Handle -> Readyness -> (a -> b) -> IO (Maybe b, Maybe Handle)
nextOut _ EndOfFile _ = return (Nothing, Nothing)
nextOut handle Unready _ = return (Nothing, Just handle)
nextOut handle Ready constructor =
do
a <- hGetNonBlocking handle bufSize
case length a of
0 -> do hClose handle
return (Nothing, Nothing)
_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