45 lines
1.6 KiB
Haskell
45 lines
1.6 KiB
Haskell
|
{-# LANGUAGE LambdaCase #-}
|
||
|
|
|
||
|
|
module Process where
|
||
|
|
|
||
|
|
import Control.Concurrent
|
||
|
|
import Control.Exception
|
||
|
|
import Control.Monad
|
||
|
|
|
||
|
|
import System.Directory
|
||
|
|
import System.Exit
|
||
|
|
import System.Posix.Signals
|
||
|
|
import System.Posix.Types
|
||
|
|
import System.Process (waitForProcess)
|
||
|
|
import System.Process.Internals
|
||
|
|
( ProcessHandle__ (ClosedHandle, OpenHandle)
|
||
|
|
, mkProcessHandle
|
||
|
|
, withProcessHandle
|
||
|
|
)
|
||
|
|
|
||
|
|
-- | Block until a PID has exited (in any form)
|
||
|
|
-- ASSUMPTION on linux PIDs will always increase until they overflow, in which
|
||
|
|
-- case they will start to recycle. Barring any fork bombs, this code should
|
||
|
|
-- work because we can reasonably expect that no processes will spawn with the
|
||
|
|
-- same PID within the delay limit
|
||
|
|
-- TODO this will not work if the process is a zombie (maybe I care...)
|
||
|
|
waitUntilExit :: Show t => t -> IO ()
|
||
|
|
waitUntilExit pid = do
|
||
|
|
res <- doesDirectoryExist $ "/proc/" ++ show pid
|
||
|
|
when res $ threadDelay 100000 >> waitUntilExit pid
|
||
|
|
|
||
|
|
killPID :: ProcessID -> IO ()
|
||
|
|
killPID pid = do
|
||
|
|
h <- mkProcessHandle pid False
|
||
|
|
-- this may fail of the PID does not exist
|
||
|
|
_ <- try $ sendSIGTERM h :: IO (Either IOException ())
|
||
|
|
-- this may fail if the process exits instantly and the handle
|
||
|
|
-- is destroyed by the time we get to this line (I think?)
|
||
|
|
_ <- try $ waitForProcess h :: IO (Either IOException ExitCode)
|
||
|
|
return ()
|
||
|
|
where
|
||
|
|
sendSIGTERM h = withProcessHandle h $ \case
|
||
|
|
OpenHandle _ -> signalProcess sigTERM pid
|
||
|
|
ClosedHandle _ -> return ()
|
||
|
|
_ -> return () -- this should never happen
|