Неблокируемое чтение из подпроцесса в Haskell

Question

Каков наилучший способ записи в stdin и чтение из stdout подпроцесса без блокировки?

Подпроцесс был создан с помощью System.IO.createProcess, который возвращает дескрипторы для записи и чтения из подпроцесса. Запись и чтение выполняются в текстовом формате.

Например, моя лучшая попытка выполнить неблокируемое чтение: timeout 1 $ hGetLine out, который возвращает Just "some line" или Nothing, если строка не существует для чтения. Однако это кажется взломом для меня, поэтому я ищу более «стандартный» способ.

Благодаря

Answer 1

Вот некоторые примеры того, как взаимодействовать с порожденным процессом в моде, упомянутой @jberryman.

программа взаимодействует со сценарием ./compute, который просто считывает строку из стандартного ввода в форме <x> <y> и возвращает х +- после задержки у секунд. Более подробная информация: this gist.

Существует много предостережений при взаимодействии с порожденными процессами. Чтобы избежать «страдания от буферизации», вам необходимо очистить исходящую трубу всякий раз, когда вы отправляете входные данные, а порожденный процесс должен сбрасывать stdout каждый раз, когда он отправляет ответ. Взаимодействие с процессом с помощью псевдо-tty является альтернативой, если вы обнаружите, что stdout не сбрасывается достаточно быстро.

Кроме того, в примерах предполагается, что закрытие входной трубы приведет к прекращению процесса появления. Если это не так, вам нужно будет отправить сигнал для обеспечения завершения.

Вот пример кода - см. Подпрограмму main в конце для выборочных вызовов.

import System.Environment 
import System.Timeout (timeout) 
import Control.Concurrent 
import Control.Concurrent (forkIO, threadDelay, killThread) 
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 

import System.Process 
import System.IO 

-- blocking IO 
main1 cmd tmicros = do 
    r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe } 
    let (Just inp, Just outp, _, phandle) = r 

    hSetBuffering inp NoBuffering 
    hPutStrLn inp cmd  -- send a command 

    -- block until the response is received 
    contents <- hGetLine outp 
    putStrLn $ "got: " ++ contents 

    hClose inp   -- and close the pipe 
    putStrLn "waiting for process to terminate" 
    waitForProcess phandle 

-- non-blocking IO, send one line, wait the timeout period for a response 
main2 cmd tmicros = do 
    r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe } 
    let (Just inp, Just outp, _, phandle) = r 

    hSetBuffering inp NoBuffering 
    hPutStrLn inp cmd -- send a command, will respond after 4 seconds 

    mvar <- newEmptyMVar 
    tid <- forkIO $ hGetLine outp >>= putMVar mvar 

    -- wait the timeout period for the response 
    result <- timeout tmicros (takeMVar mvar) 
    killThread tid 

    case result of 
    Nothing -> putStrLn "timed out" 
    Just x -> putStrLn $ "got: " ++ x 

    hClose inp   -- and close the pipe 
    putStrLn "waiting for process to terminate" 
    waitForProcess phandle 

-- non-block IO, send one line, report progress every timeout period 
main3 cmd tmicros = do 
    r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe } 
    let (Just inp, Just outp, _, phandle) = r 

    hSetBuffering inp NoBuffering 
    hPutStrLn inp cmd -- send command 

    mvar <- newEmptyMVar 
    tid <- forkIO $ hGetLine outp >>= putMVar mvar 

    -- loop until response received; report progress every timeout period 
    let loop = do result <- timeout tmicros (takeMVar mvar) 
       case result of 
        Nothing -> putStrLn "still waiting..." >> loop 
        Just x -> return x 
    x <- loop 
    killThread tid 

    putStrLn $ "got: " ++ x 

    hClose inp   -- and close the pipe 
    putStrLn "waiting for process to terminate" 
    waitForProcess phandle 

{- 

Usage: ./prog which delay timeout 

    where 
    which = main routine to run: 1, 2 or 3 
    delay = delay in seconds to send to compute script 
    timeout = timeout in seconds to wait for response 

E.g.: 

    ./prog 1 4 3 -- note: timeout is ignored for main1 
    ./prog 2 2 3 -- should timeout 
    ./prog 2 4 3 -- should get response 
    ./prog 3 4 1 -- should see "still waiting..." a couple of times 

-} 

main = do 
    (which : vtime : tout : _) <- fmap (map read) getArgs 
    let cmd = "10 " ++ show vtime 
     tmicros = 1000000*tout :: Int 
    case which of 
    1 -> main1 cmd tmicros 
    2 -> main2 cmd tmicros 
    3 -> main3 cmd tmicros 
    _ -> error "huh?"