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