{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Test.Sandbox.Process where import System.Posix.Types import System.Posix.Signals import Text.Regex.Posix import Data.Maybe import Control.Exception import Control.Monad import System.Directory import qualified Data.Set as S #if defined(__MACOSX__) || defined(__WIN32__) #else data ProcessInfo = ProcessInfo { ProcessInfo -> ProcessID piPid :: ProcessID , ProcessInfo -> String piStat :: String , ProcessInfo -> ProcessID piPpid :: ProcessID , ProcessInfo -> ProcessID piPgid :: ProcessGroupID } deriving (Int -> ProcessInfo -> ShowS [ProcessInfo] -> ShowS ProcessInfo -> String (Int -> ProcessInfo -> ShowS) -> (ProcessInfo -> String) -> ([ProcessInfo] -> ShowS) -> Show ProcessInfo forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ProcessInfo] -> ShowS $cshowList :: [ProcessInfo] -> ShowS show :: ProcessInfo -> String $cshow :: ProcessInfo -> String showsPrec :: Int -> ProcessInfo -> ShowS $cshowsPrec :: Int -> ProcessInfo -> ShowS Show,ProcessInfo -> ProcessInfo -> Bool (ProcessInfo -> ProcessInfo -> Bool) -> (ProcessInfo -> ProcessInfo -> Bool) -> Eq ProcessInfo forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ProcessInfo -> ProcessInfo -> Bool $c/= :: ProcessInfo -> ProcessInfo -> Bool == :: ProcessInfo -> ProcessInfo -> Bool $c== :: ProcessInfo -> ProcessInfo -> Bool Eq,ReadPrec [ProcessInfo] ReadPrec ProcessInfo Int -> ReadS ProcessInfo ReadS [ProcessInfo] (Int -> ReadS ProcessInfo) -> ReadS [ProcessInfo] -> ReadPrec ProcessInfo -> ReadPrec [ProcessInfo] -> Read ProcessInfo forall a. (Int -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [ProcessInfo] $creadListPrec :: ReadPrec [ProcessInfo] readPrec :: ReadPrec ProcessInfo $creadPrec :: ReadPrec ProcessInfo readList :: ReadS [ProcessInfo] $creadList :: ReadS [ProcessInfo] readsPrec :: Int -> ReadS ProcessInfo $creadsPrec :: Int -> ReadS ProcessInfo Read) getProcessInfo :: String -> Maybe ProcessInfo getProcessInfo :: String -> Maybe ProcessInfo getProcessInfo String v = if String v String -> String -> Bool forall source source1 target. (RegexMaker Regex CompOption ExecOption source, RegexContext Regex source1 target) => source1 -> source -> target =~ String pattern then case String v String -> String -> [[String]] forall source source1 target. (RegexMaker Regex CompOption ExecOption source, RegexContext Regex source1 target) => source1 -> source -> target =~ String pattern of [[String _str,String pid,String stat,String ppid,String pgid]] -> ProcessInfo -> Maybe ProcessInfo forall a. a -> Maybe a Just (ProcessInfo -> Maybe ProcessInfo) -> ProcessInfo -> Maybe ProcessInfo forall a b. (a -> b) -> a -> b $ ProcessID -> String -> ProcessID -> ProcessID -> ProcessInfo ProcessInfo (String -> ProcessID forall a. Read a => String -> a read String pid) String stat (String -> ProcessID forall a. Read a => String -> a read String ppid) (String -> ProcessID forall a. Read a => String -> a read String pgid) [[String]] _ -> Maybe ProcessInfo forall a. Maybe a Nothing else Maybe ProcessInfo forall a. Maybe a Nothing where pattern :: String pattern = String "^([0-9]+) \\([^\\)]*\\) ([RSDZTW]) ([0-9]+) ([0-9]+) [0-9]+ .*" getProcessInfos :: IO [ProcessInfo] getProcessInfos :: IO [ProcessInfo] getProcessInfos = do [String] dirs <- String -> IO [String] getDirectoryContents String "/proc" let processes :: [String] processes = (String -> Bool) -> [String] -> [String] forall a. (a -> Bool) -> [a] -> [a] filter ( String -> String -> Bool forall source source1 target. (RegexMaker Regex CompOption ExecOption source, RegexContext Regex source1 target) => source1 -> source -> target =~ String "[0-9]+") [String] dirs [Maybe ProcessInfo] stats <- [String] -> (String -> IO (Maybe ProcessInfo)) -> IO [Maybe ProcessInfo] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [String] processes ((String -> IO (Maybe ProcessInfo)) -> IO [Maybe ProcessInfo]) -> (String -> IO (Maybe ProcessInfo)) -> IO [Maybe ProcessInfo] forall a b. (a -> b) -> a -> b $ \String ps -> do { String file <- (String -> IO String readFile (String -> IO String) -> String -> IO String forall a b. (a -> b) -> a -> b $ String "/proc/" String -> ShowS forall a. [a] -> [a] -> [a] ++ String ps String -> ShowS forall a. [a] -> [a] -> [a] ++ String "/stat") ; String file String -> IO (Maybe ProcessInfo) -> IO (Maybe ProcessInfo) `seq` Maybe ProcessInfo -> IO (Maybe ProcessInfo) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe ProcessInfo -> IO (Maybe ProcessInfo)) -> Maybe ProcessInfo -> IO (Maybe ProcessInfo) forall a b. (a -> b) -> a -> b $ String -> Maybe ProcessInfo getProcessInfo String file } IO (Maybe ProcessInfo) -> (SomeException -> IO (Maybe ProcessInfo)) -> IO (Maybe ProcessInfo) forall e a. Exception e => IO a -> (e -> IO a) -> IO a `catch` (\(SomeException _ :: SomeException) -> Maybe ProcessInfo -> IO (Maybe ProcessInfo) forall (m :: * -> *) a. Monad m => a -> m a return Maybe ProcessInfo forall a. Maybe a Nothing) [ProcessInfo] -> IO [ProcessInfo] forall (m :: * -> *) a. Monad m => a -> m a return ([ProcessInfo] -> IO [ProcessInfo]) -> [ProcessInfo] -> IO [ProcessInfo] forall a b. (a -> b) -> a -> b $ [Maybe ProcessInfo] -> [ProcessInfo] forall a. [Maybe a] -> [a] catMaybes [Maybe ProcessInfo] stats getProcessGroupIDs :: IO [ProcessGroupID] getProcessGroupIDs :: IO [ProcessID] getProcessGroupIDs = do [ProcessInfo] infos <- IO [ProcessInfo] getProcessInfos [ProcessID] -> IO [ProcessID] forall (m :: * -> *) a. Monad m => a -> m a return ([ProcessID] -> IO [ProcessID]) -> [ProcessID] -> IO [ProcessID] forall a b. (a -> b) -> a -> b $ (ProcessInfo -> ProcessID) -> [ProcessInfo] -> [ProcessID] forall a b. (a -> b) -> [a] -> [b] map (\ProcessInfo info -> ProcessInfo -> ProcessID piPgid ProcessInfo info) [ProcessInfo] infos getProcessIDs :: [ProcessGroupID] -> IO [ProcessID] getProcessIDs :: [ProcessID] -> IO [ProcessID] getProcessIDs [ProcessID] pgids = do [ProcessInfo] infos <- IO [ProcessInfo] getProcessInfos let pgids' :: Set ProcessID pgids' = [ProcessID] -> Set ProcessID forall a. Ord a => [a] -> Set a S.fromList ([ProcessID] -> Set ProcessID) -> [ProcessID] -> Set ProcessID forall a b. (a -> b) -> a -> b $ [ProcessID] pgids [ProcessID] -> IO [ProcessID] forall (m :: * -> *) a. Monad m => a -> m a return ([ProcessID] -> IO [ProcessID]) -> [ProcessID] -> IO [ProcessID] forall a b. (a -> b) -> a -> b $ (ProcessInfo -> ProcessID) -> [ProcessInfo] -> [ProcessID] forall a b. (a -> b) -> [a] -> [b] map (\ProcessInfo info -> ProcessInfo -> ProcessID piPid ProcessInfo info) ([ProcessInfo] -> [ProcessID]) -> [ProcessInfo] -> [ProcessID] forall a b. (a -> b) -> a -> b $ (ProcessInfo -> Bool) -> [ProcessInfo] -> [ProcessInfo] forall a. (a -> Bool) -> [a] -> [a] filter (\ProcessInfo info -> ProcessID -> Set ProcessID -> Bool forall a. Ord a => a -> Set a -> Bool S.member (ProcessInfo -> ProcessID piPgid ProcessInfo info) Set ProcessID pgids') [ProcessInfo] infos #endif cleanUpProcessGroupIDs :: [ProcessGroupID] -> IO () cleanUpProcessGroupIDs :: [ProcessID] -> IO () cleanUpProcessGroupIDs [ProcessID] pgids = do [ProcessID] -> (ProcessID -> IO ()) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [ProcessID] pgids ((ProcessID -> IO ()) -> IO ()) -> (ProcessID -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \ProcessID pgid -> do Signal -> ProcessID -> IO () signalProcessGroup Signal sigKILL ProcessID pgid IO () -> (SomeException -> IO ()) -> IO () forall e a. Exception e => IO a -> (e -> IO a) -> IO a `catch` (\(SomeException _::SomeException) -> () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return ())