Haskell: cómo agotar el tiempo una función que ejecuta un comando externo

timeout external-process

Question

Llamo a un programa externo dentro de una función. Ahora me gustaría agotar esta función y no solo el programa externo. Pero después de que la función se agote, el programa externo todavía se está ejecutando en mi computadora (estoy usando debian) hasta que finalice su cálculo, después de eso su hilo aún permanece en la tabla de procesos como un subproceso de mi programa principal hasta que el programa principal termina

Aquí hay dos ejemplos mínimos que ilustran lo que me gustaría hacer. El primero usa unsafePerformIO, el segundo está completamente en la mónada IO. Realmente no dependo del unsafePerformIO pero me gustaría mantenerlo si es posible. El problema descrito ocurre con y sin él.

Con unsafePerformIO

module Main where

import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process

main = do
    x <- time $ timeoutP (1 * 1000000) $ mytest 2
    y <- getLine
    putStrLn $ show x ++ y

timeoutP :: Int -> a -> IO (Maybe a)
timeoutP t fun = timeout t $ return $! fun

mytest :: Int -> String
mytest n =
  let
    x = runOnExternalProgram $ n * 1000
  in
    x ++ ". Indeed."

runOnExternalProgram :: Int -> String
runOnExternalProgram n = unsafePerformIO $ do
    -- convert the input to a parameter of the external program
    let x = show $ n + 12
    -- run the external program
    -- (here i use "sleep" to indicate a slow computation)
    answer <- readProcess "sleep" [x] ""
    -- convert the output as needed
    let verboseAnswer = "External program answered: " ++ answer
    return verboseAnswer

Sin unsafePerformIO

module Main where

import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process

main = do
    x <- time $ timeout (1 * 1000000) $ mytest 2
    y <- getLine
    putStrLn $ show x ++ y

mytest :: Int -> IO String
mytest n = do
    x <- runOnExternalProgram $ n * 1000
    return $ x ++ ". Indeed."

runOnExternalProgram :: Int -> IO String
runOnExternalProgram n = do
    -- convert the input to a parameter for the external program:
    let x = show $ n + 12
    -- run the external program
    -- (here i use "sleep" to indicate a slow computation):
    answer <- readProcess "sleep" [x] ""
    -- convert the output as needed:
    let verboseAnswer = "External program answered: " ++ answer
    return verboseAnswer

Tal vez el soporte puede ser de ayuda aquí, pero realmente no sé cómo.

Edit: Adopté la respuesta de John L. Ahora estoy usando lo siguiente:

import Control.Concurrent
import Control.Exception
import System.Exit
import System.IO
import System.IO.Error
import System.Posix.Signals
import System.Process
import System.Process.Internals

safeCreateProcess :: String -> [String] -> StdStream -> StdStream -> StdStream
                  -> ( ( Maybe Handle
                       , Maybe Handle
                       , Maybe Handle
                       , ProcessHandle
                       ) -> IO a )
                  -> IO a
safeCreateProcess prog args streamIn streamOut streamErr fun = bracket
    ( do
        h <- createProcess (proc prog args) 
                 { std_in  = streamIn
                 , std_out = streamOut
                 , std_err = streamErr
                 , create_group = True }
        return h
    )
-- "interruptProcessGroupOf" is in the new System.Process. Since some
-- programs return funny exit codes i implemented a "terminateProcessGroupOf".
--    (/(_, _, _, ph) -> interruptProcessGroupOf ph >> waitForProcess ph)
    (/(_, _, _, ph) -> terminateProcessGroup ph >> waitForProcess ph)
    fun
{-# NOINLINE safeCreateProcess #-}

safeReadProcess :: String -> [String] -> String -> IO String
safeReadProcess prog args str =
    safeCreateProcess prog args CreatePipe CreatePipe Inherit
      (/(Just inh, Just outh, _, ph) -> do
        hPutStr inh str
        hClose inh
        -- fork a thread to consume output
        output <- hGetContents outh
        outMVar <- newEmptyMVar
        forkIO $ evaluate (length output) >> putMVar outMVar ()
        -- wait on output
        takeMVar outMVar
        hClose outh
        return output
-- The following would be great, if some programs did not return funny
-- exit codes!
--            ex <- waitForProcess ph
--            case ex of
--                ExitSuccess -> return output
--                ExitFailure r ->
--                    fail ("spawned process " ++ prog ++ " exit: " ++ show r)
      )

terminateProcessGroup :: ProcessHandle -> IO ()
terminateProcessGroup ph = do
    let (ProcessHandle pmvar) = ph
    ph_ <- readMVar pmvar
    case ph_ of
        OpenHandle pid -> do  -- pid is a POSIX pid
            signalProcessGroup 15 pid
        otherwise -> return ()

Esto resuelve mi problema. Mata todos los procesos secundarios del proceso generado y eso en el momento adecuado.

Saludos cordiales.

Answer 1

Edición: es posible obtener el pid del proceso generado. Puedes hacerlo con código como el siguiente:

-- highly non-portable, and liable to change between versions
import System.Process.Internals

-- from the finalizer of the bracketed function
-- `ph` is a ProcessHandle as returned by createProcess
  (/(_,_,_,ph) -> do
    let (ProcessHandle pmvar) = ph
    ph_ <- takeMVar pmvar
    case ph_ of
      OpenHandle pid -> do  -- pid is a POSIX pid
        ... -- do stuff
        putMVar pmvar ph_

Si ph_ el proceso, en lugar de poner el ph_ abierto en el mvar, debe crear un ClosedHandle apropiado y devolverlo en su lugar. Es importante que este código se ejecute enmascarado (el corchete lo hará por usted).

Ahora que tiene una identificación POSIX, puede usar las llamadas del sistema o desembolsar para matar según sea necesario. Solo tenga cuidado de que su ejecutable Haskell no esté en el mismo grupo de proceso si va por esa ruta.

/ fin de edición

Este comportamiento parece algo sensato. La documentación para el timeout de timeout afirma que no funciona en absoluto para el código que no es de Haskell, y de hecho no veo ninguna forma en que pueda hacerlo de forma genérica. Lo que ocurre es que readProcess genera un nuevo proceso, pero luego se agota el tiempo de espera mientras se espera la salida de ese proceso. Parece que readProcess no finaliza el proceso generado cuando se cancela de forma anormal. Esto podría ser un error en readProcess , o podría ser por diseño.

Como solución, creo que necesitarás implementar algo de esto tú mismo. timeout funciona elevando una excepción asíncrona en un subproceso generado. Si envuelve su runOnExternalProgram en un controlador de excepciones, obtendrá el comportamiento que desea.

La función clave aquí es el nuevo runOnExternalProgram , que es una combinación de su función original y readProcess . Sería mejor (más modular, más reutilizable, más readProcess mantener) hacer un nuevo proceso de readProcess que readProcess el proceso generado cuando se produce una excepción, pero lo dejaré como un ejercicio.

module Main where

import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
import Control.Exception
import System.IO
import System.IO.Error
import GHC.IO.Exception
import System.Exit
import Control.Concurrent.MVar
import Control.Concurrent

main = do
    x <- time $ timeoutP (1 * 1000000) $ mytest 2
    y <- getLine
    putStrLn $ show x ++ y

timeoutP :: Int -> IO a -> IO (Maybe a)
timeoutP t fun = timeout t $ fun

mytest :: Int -> IO String
mytest n = do
  x <- runOnExternalProgram $ n * 1000
  return $ x ++ ". Indeed."

runOnExternalProgram :: Int -> IO String
runOnExternalProgram n = 
    -- convert the input to a parameter of the external program
    let x = show $ n + 12
    in bracketOnError
        (createProcess (proc "sleep" [x]){std_in = CreatePipe
                                         ,std_out = CreatePipe
                                         ,std_err = Inherit})
        (/(Just inh, Just outh, _, pid) -> terminateProcess pid >> waitForProcess pid)

        (/(Just inh, Just outh, _, pid) -> do
          -- fork a thread to consume output
          output <- hGetContents outh
          outMVar <- newEmptyMVar
          forkIO $ evaluate (length output) >> putMVar outMVar ()

          -- no input in this case
          hClose inh

          -- wait on output
          takeMVar outMVar
          hClose outh

          -- wait for process
          ex <- waitForProcess pid

          case ex of
            ExitSuccess -> do
              -- convert the output as needed
              let verboseAnswer = "External program answered: " ++ output
              return verboseAnswer
            ExitFailure r ->
              ioError (mkIOError OtherError ("spawned process exit: " ++ show r) Nothing Nothing) )