Haskell: как отключить функцию, выполняющую внешнюю команду
Я вызываю внешнюю программу внутри функции. Теперь я хотел бы отключить эту функцию, а не только внешнюю программу. Но после того, как функция истечет, внешняя программа все еще работает на моем компьютере (я использую debian) до тех пор, пока она не закончит вычисление, после чего ее поток по-прежнему остается в таблице процессов как подпрограмма моей основной программы до тех пор, пока основная программа завершается.
Вот два минимальных примера, которые иллюстрируют то, что я хотел бы сделать. Первый использует unsafePerformIO, второй - полностью в монаде IO. Я действительно не зависим от небезопасногоPerformIO, но хотел бы сохранить его, если это возможно. Описанная проблема происходит с ней и без нее.
С небезопаснымPerformIO
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
Изменить: можно получить 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, вы можете использовать системные вызовы или оболочку, чтобы убить при необходимости. Просто будьте осторожны, если ваш исполняемый файл Haskell не находится в той же группе процессов, если вы идете по этому маршруту.
/end edit
Такое поведение кажется разумным. Документация для timeout утверждает, что она вообще не работает для кода, отличного от Haskell, и, действительно, я не вижу способа, которым он мог бы быть в целом. Случается, что readProcess порождает новый процесс, но затем время ожидания, ожидая выхода из этого процесса. Похоже, что readProcess не прерывает порожденный процесс, когда он прерывается ненормально. Это может быть ошибка в readProcess, или это может быть по дизайну.
Как обходной путь, я думаю, вам нужно реализовать часть этого самостоятельно. timeout работает, создавая исключение async в порожденном потоке. Если вы обернете 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) )
