Haskell: Как отключить функцию, которая запускает внешнюю команду - PullRequest
Новая
       9

Haskell: Как отключить функцию, которая запускает внешнюю команду

16 голосов
/ 11 января 2012

Я вызываю внешнюю программу внутри функции. Теперь я хотел бы отключить эту функцию, а не только внешнюю программу. Но после истечения времени ожидания функции внешняя программа все еще работает на моем компьютере (я использую debian), пока не завершит свои вычисления, после чего ее поток все еще остается в таблице процессов как подпроцесс моей основной программы до основной программы завершается.

Вот два минимальных примера, которые иллюстрируют то, что я хотел бы сделать. Первый использует unsafePerformIO, второй полностью находится в монаде ввода-вывода. Я не очень зависим от unsafePerformIO, но хотел бы сохранить его, если это возможно. Описанная проблема возникает с и без него.

С 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

Без 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

Может, здесь поможет скобка, но я не знаю, как.

Редактировать: я принял ответ Джона Л. Сейчас я использую следующее: 

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

Это решает мою проблему. Это убивает все дочерние процессы порожденного процесса и это в нужное время.

С уважением.

1 Ответ

9 голосов
/ 11 января 2012

Редактировать: можно получить pid порожденного процесса.Вы можете сделать это с помощью кода, подобного следующему: 

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

Если вы убьете процесс, вместо того, чтобы помещать открытый ph_ в mvar, вы должны создать соответствующий ClosedHandle и вернуть его обратно.Важно, чтобы этот код выполнялся в маске (скобка сделает это за вас).

Теперь, когда у вас есть идентификатор POSIX, вы можете использовать системные вызовы или shell для уничтожения по мере необходимости.Просто будьте осторожны, если ваш исполняемый файл Haskell не входит в ту же группу процессов, если вы идете по этому пути.

/ end edit

Такое поведение кажется разумным.В документации для timeout утверждается, что она вообще не работает для кода, не относящегося к Haskell, и, действительно, я не вижу способа, который мог бы это сделать в общем.Происходит то, что readProcess порождает новый процесс, но затем истекает время ожидания его вывода.Кажется, что readProcess не завершает порожденный процесс, когда он ненормально прерван.Это может быть ошибка в readProcess, или это может быть задумано.

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

Ключевой функцией здесь является новый runOnExternalProgram, который является комбинацией вашей исходной функции и readProcess,Было бы лучше (более модульным, более повторно используемым, более обслуживаемым) создать новый readProcess, который убивает порожденный процесс при возникновении исключения, но я оставлю это как упражнение. 

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