Haskell: start a long running process, silently, capturing stdout

Question

I have a long running process which I need to start. It takes a few seconds to start, and outputs logs to stdout, with one that indicates it is ready.

I would like to:

start the process silently, so that the stdout from the process is not displayed in my session.
capture the output as it streams so that I can determine that it is ready.
have some handle on the process so that I can stop the process at a later point.

I have come close using Shelly, Turtle and System.Process, but fail to capture the stdout.

Using System.Process I had:

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import System.IO
import System.Process

startService :: IO ProcessHandle
startService = do
  let cmd = "./my-service"
      args = [ "-p 1234" ]
  (_, Just hout, _, p) <- createProcess $ (proc cmd args) { std_out = CreatePipe }
  started <- either id id <$> race (checkStarted hout) timeOut
  unless started $ fail "Service not started"
  pure p
  where
    checkStarted :: Handle -> IO Bool
    checkStarted h = do
      str <- hGetLine h
      -- check str for started log, else loop

    timeOut :: IO Bool
    timeOut = do
      threadDelay 10000000
      pure False

But The handler hout was never in a ready state.

Using Shelly I had:

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import Control.Concurrent.MVar
import Shelly
import System.IO

startService :: IO (Async ())
startService = do
  let cmd = "./my-service"
      args = [ "-p 1234" ]
  startedMVar <- newEmptyMVar
  async <- shelly $ asyncSh $ runHandle cmd args $ recordWhenStarted startedMVar
  started <- either id id <$> race (readMVar startedMVar) timeOut
  unless started $ fail "Service not started"
  pure async
  where
    recordWhenStarted :: MVar Bool -> Text -> IO ()
    recordWhenStarted mvar txt =
      when (isStartedLog txt) $
        modifyMVar_ mvar (const $ pure True)

    timeOut :: IO Bool
    timeOut = do
      threadDelay 10000000
      pure False

But the recordWhenStarted is never called.

By defining `checkStarted h = True <$ hGetLine h` and replacing `"./my-service"` with `"yes"` I can get your first version to work (to actually access the handle outside the function you have to have `pure (hout, p)`). I would guess that the reason it isn't working has to do with `my-service` and not with your Haskell code. — user2407038, Dec 13 '17 at 18:31
In the terminal I just tried the 'my-service' redirecting stdout to file with no luck. Turns out, the log output is being produced via stderr, hence why my code wasnt working — tmortiboy, Dec 13 '17 at 22:56

score 3 · Answer 1 · answered Dec 13 '17 at 08:03

The following is example of starting process and reading stdout in a program of mine:

  runMystem :: [T.Text] -> IO T.Text
  runMystem stemWords = do
    (i, o, _, ph) <- createProcess (proc mystemExecutabe mystemParams) { std_in = CreatePipe, std_out = CreatePipe }
    res <- flip (maybe (return T.empty)) i $ \hIn ->
              flip (maybe (return T.empty)) o $ \hOut -> do
                hSetEncoding hIn utf8
                hSetEncoding hOut utf8
                forM_ stemWords $ TIO.hPutStrLn hIn
                TIO.hGetContents hOut
    void $ waitForProcess ph
    return res

danidiaz · Answer 2 · 2017-12-14T07:28:07.003

This answer uses the process-streaming library (written by the author of this answer) which is a set of helpers over process.

{-# language OverloadedStrings #-}
{-# language NumDecimals #-}
import           System.Process.Streaming (execute,piped,shell,foldOut,transduce1)
import qualified System.Process.Streaming.Text as PT
import           Data.Text.Lazy (isInfixOf)
import           Control.Applicative
import           Control.Monad
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async
import           Control.Concurrent.MVar

main :: IO ()
main = do
    started <- newEmptyMVar
    let execution =
            execute (piped (shell "{ sleep 3 ; echo fooo ; sleep 3 ; }")) $
                foldOut . transduce1 PT.utf8x . PT.eachLine $ lookline
        lookline line = do
            when (isInfixOf "foo" line) (putMVar started ())
            return (Right ())
        stopOrNot =
            do abort <- race (threadDelay 4e6) (readMVar started)
               case abort of
                   Left () -> return () -- stop immediately
                   Right () -> runConcurrently empty -- sleep forever
    result <- race stopOrNot execution
    print result

execute installs exception handlers that terminate the external process when an asynchronous exceptions arrives, to it is safe to use race with it.

execute also takes care to drain any standard stream that is not read explicitly (like stderr in this case) to avoid a common source of deadlocks.

Haskell: start a long running process, silently, capturing stdout

2 Answers2