Haskell: Comment délai d'attente d'une fonction qui exécute une commande externe

Question

J'appelle un programme externe dans une fonction. Maintenant, je voudrais Timeout cette fonction et non pas seulement le programme externe. Mais après les temps de fonctionnement hors, le programme externe est toujours en cours d'exécution sur mon ordinateur (je debian) jusqu'à ce qu'il termine son calcul, après que son fils reste dans la table de processus comme subthread de mon programme principal jusqu'à ce que le programme principal se termine.

Voici deux exemples minimes qui illustre ce que je voudrais faire. Les premières utilisations unsafePerformIO, la seconde est complètement dans la monade IO. Je ne dépends pas vraiment sur le unsafePerformIO mais je voudrais le garder si possible. Le problème décrit avec et sans occures il.

Avec 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

Sans 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

Peut-être que le support peut être utile, mais je ne sais pas vraiment comment.

Edit: J'adopté la réponse de John L'. Maintenant, je suis en utilisant ce qui suit:

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 ()

Cela résout mon problème. Il tue tous les processus enfants du processus donné naissance et que, au bon moment.

Amicalement.

Answer 1

Edit: il est possible d'obtenir le pid du processus donné naissance. Vous pouvez le faire avec le code comme suit:

-- 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 vous tuez le processus, au lieu de mettre l'ph_ ouverte dans le Mvar vous devez créer un ClosedHandle approprié et remettre tout ça à la place. Il est important que ce code est exécuté masqué (support fera pour vous).

Maintenant que vous avez un identifiant POSIX, vous pouvez utiliser les appels système ou débourser pour tuer au besoin. Faites juste attention que votre exécutable Haskell n'est pas dans le même groupe de processus si vous allez dans cette voie.

/ modifier fin

Ce comportement semble sorte de sensible. La documentation pour les demandes de timeout qu'il ne fonctionne pas du tout pour le code non-Haskell, et en fait je ne vois pas de quelque façon que ce pourrait génériquement. Ce qui se passe est que readProcess engendre un nouveau processus, mais est ensuite arrivée à expiration en attendant la sortie de ce processus. Il semble que readProcess ne se termine pas le processus donné naissance quand il est anormalement avorté. Cela pourrait être un bogue dans readProcess, ou il pourrait être par la conception.

Pour contourner ce problème, je pense que vous aurez besoin de mettre en œuvre une partie de vous-même. timeout travaille en soulevant une exception async dans un fil donné naissance. Si vous enveloppez votre runOnExternalProgram dans un gestionnaire d'exception, vous obtiendrez le comportement que vous voulez.

La fonction clé ici est la nouvelle runOnExternalProgram, qui est une combinaison de votre fonction d'origine et readProcess. Il serait mieux (plus modulaire, plus réutilisable, plus maintenable) pour faire une nouvelle readProcess qui tue le processus donné naissance lorsqu'une exception est levée, mais je vais laisser cela comme un exercice.

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) )