module System.Linux.Proc (
ProcessName,
ProcessState (..),
ProcStatus (..),
UID,
UserName,
UserDatabase,
procGetProcessDirs,
procGetAllProcessStatus,
getUserDatabase,
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Char
import Data.Int
import Data.List
import Data.List.Split
import Data.Map (Map)
import Data.Maybe
import Data.Typeable
import Data.Word
import System.Directory
import System.Exit
import System.FilePath
import System.IO.Error
import System.Posix.Types
import System.Process
import Text.Regex.TDFA
import Text.XFormat.Read
import qualified Control.Exception as Exc
import qualified Data.Map as M
import qualified System.IO.Strict as IO
type ProcessName = String
type ProcessInfo = [String]
data ProcessState = Running
| Sleeping
| Waiting
| Zombie
| Traced
| Paging
deriving (Show, Read, Ord, Eq, Typeable)
type UID = Int
type UserName = String
type UserDatabase = Map UID UserName
type CPUTime = (Int, Int, Int, Int, Int)
type CPUTimeDatabase = Map Int (Maybe CPUTime)
data ProcStatus =
ProcStatus {psProcessId :: Int
,psCommand :: String
,psState :: ProcessState
,psParentProcessId:: Int
,psProcessGroupId :: Int
,psSessionId :: Int
,psNice :: Int
,psNumThreads :: Int
,psVirtualMem :: Int
,psResidentMem :: Int
,psUID :: Int
,psUsername :: String
,psCmdline :: String
,psCpuPercent :: Double
} deriving (Show, Read, Ord, Eq, Typeable)
procPath :: FilePath
procPath = "/proc"
procStatFile :: FilePath
procStatFile = "stat"
procStatusFile :: FilePath
procStatusFile = "status"
procCmdlineFile :: FilePath
procCmdlineFile = "cmdline"
psCommandBox = (1, String, "psCommandBox")
psStateBox = (2, Char, "psStateBox")
psParentProcessIdBox = (3, Int, "psParentProcessIdBox")
psProcessGroupIdBox = (4, Int, "psProcessGroupIdBox")
psSessionIdBox = (5, Int, "psSessionIdBox")
psUtimeBox = (13, Int, "psUtimeBox")
psStimeBox = (14, Int, "psStimeBox")
psCutimeBox = (15, Int, "psCutimeBox")
psCstimeBox = (16, Int, "psCstimeBox")
psNiceBox = (18, Int, "psNiceBox")
psNumThreadsBox = (19, Int, "psNumThreadsBox")
psProcessorBox = (38, Int, "psProcessorBox")
procGetProcessDirs :: IO [FilePath]
procGetProcessDirs =
getDirectoryContents procPath
>>= filterM (\x -> doesDirectoryExist $ procPath </> x)
>>= \dirs -> return $ filter isIntegerString dirs
procGetProcessIDs :: IO [Int]
procGetProcessIDs =
liftM (map (\x -> read x :: Int)) procGetProcessDirs
procGetProcessStatus :: Int -> UserDatabase -> IO (Maybe (String, ProcessState, Int, Int, Int, Int, Int, Int, Int, Int, String, String, Int))
procGetProcessStatus pid database = do
info <- procGetStatInfo pid
case info of
Just i -> do
let (cmd, state, ppid, pgid, sid, nice, threads, processor) = procParseStatInfo i
cmdline <- procGetCmdlineInfo pid
let cmdStr = head $ splitOneOf "\0 " cmdline
command =
if null cmdStr
then cmd
else takeFileName cmdStr
(vSize, vRss, uid) <- procGetStatusInfo pid
let filterMap = M.filterWithKey (\ id _ -> id == uid) database
username = if M.null filterMap
then ""
else snd $ M.findMin filterMap
return $ Just (command, state, ppid, pgid, sid, nice, threads, vSize, vRss, uid, username, cmdline, processor)
Nothing -> return Nothing
procGetAllProcessStatus :: IO [ProcStatus]
procGetAllProcessStatus = do
ids <- procGetProcessIDs
beforeDatabase <- procGetCPUTimeDatabase ids M.empty
userDatabase <- getUserDatabase
statusList <- mapM (\pid -> do
status <- procGetProcessStatus pid userDatabase
return (pid, status)
) ids
afterDatabase <- procGetCPUTimeDatabase ids M.empty
let procStatusList =
map (\ (pid, status) ->
case status of
Just (command, state, ppid, pgid, sid, nice, threads, vSize, vRss, uid, username, cmdline, processor) ->
let cpuPercent = procGetCPUPercent pid processor beforeDatabase afterDatabase
in Just $ ProcStatus pid command state
ppid pgid sid nice
threads vSize vRss
uid username cmdline
cpuPercent
Nothing -> Nothing
) statusList
return $ catMaybes procStatusList
procGetCPUPercent :: Int -> Int -> CPUTimeDatabase -> CPUTimeDatabase -> Double
procGetCPUPercent pid processor beforeDatabase afterDatabase =
let bDatabase = (M.filterWithKey (\ id _ -> id == pid) beforeDatabase)
aDatabase = M.filterWithKey (\ id _ -> id == pid) afterDatabase
in if M.null bDatabase || M.null aDatabase
then 0
else
let beforeTimes = snd $ M.findMin bDatabase
afterTimes = snd $ M.findMin aDatabase
in
if isNothing beforeTimes || isNothing afterTimes
then 0
else
let (beforeUtime, beforeStime, beforeCutime, beforeCstime, beforeTotalTime) = fromJust beforeTimes
(afterUtime, afterStime, afterCutime, afterCstime, afterTotalTime) = fromJust afterTimes
processCPUTimeDiff =
fromIntegral
(sum [afterUtime, afterStime, afterCutime, afterCstime]
sum [beforeUtime, beforeStime, beforeCutime, beforeCstime])
totalCPUTimeDiff = fromIntegral (afterTotalTime beforeTotalTime)
cpuNumber = fromIntegral processor
in if totalCPUTimeDiff == 0
then 0
else formatFloatN ((processCPUTimeDiff * 100) / totalCPUTimeDiff * cpuNumber) 2
procGetStatInfo :: Int -> IO (Maybe ProcessInfo)
procGetStatInfo pid = do
let filepath = procPath </> show pid </> procStatFile
Exc.catch
(liftM (Just . words) $ IO.readFile filepath)
(\(_ :: IOError) -> return Nothing)
procGetStatusInfo :: Int -> IO (Int, Int, Int)
procGetStatusInfo pid = do
let filepath = procPath </> show pid </> procStatusFile
Exc.catch
(do
lns <- liftM lines $ IO.readFile filepath
let pickFirstInt match list =
let matchList = filter (\x -> match `isInfixOf` x) list
in if null matchList
then 0
else
let (_, value, _) = head matchList =~ "[0-9]+" :: (String, String, String)
in if null value
then 0
else read value :: Int
size = pickFirstInt "VmSize" lns
rss = pickFirstInt "VmRSS" lns
uid = pickFirstInt "Uid" lns
return (1024 * size, 1024 * rss, uid)
)
(\(_ :: IOError) -> do
putStrLn $ "procGetStatusInfo : read " ++ filepath ++ " failed."
return (0, 0, 0))
procGetCmdlineInfo :: Int -> IO String
procGetCmdlineInfo pid = do
let filepath = procPath </> show pid </> procCmdlineFile
Exc.catch
(liftM (map (\x -> if x == '\0' then ' ' else x)) $ IO.readFile filepath)
(\(_ :: IOError) -> do
putStrLn $ "procGetCmdlineInfo : read " ++ filepath ++ " failed."
return "")
procParseStatInfo :: ProcessInfo -> (String, ProcessState, Int, Int, Int, Int, Int, Int)
procParseStatInfo info =
(toProcessName $ procPickStat info psCommandBox
,toProcessState $ procPickStat info psStateBox
,procPickStat info psParentProcessIdBox
,procPickStat info psProcessGroupIdBox
,procPickStat info psSessionIdBox
,procPickStat info psNiceBox
,procPickStat info psNumThreadsBox
,procPickStat info psProcessorBox)
procGetCPUTimeDatabase :: [Int] -> CPUTimeDatabase -> IO CPUTimeDatabase
procGetCPUTimeDatabase [] database = return database
procGetCPUTimeDatabase (x:xs) database = do
cpuTime <- procGetProcessCPUTime x
procGetCPUTimeDatabase xs $ M.insert x cpuTime database
procGetProcessCPUTime :: Int -> IO (Maybe (Int, Int, Int, Int, Int))
procGetProcessCPUTime pid = do
info <- procGetStatInfo pid
case info of
Just i -> do
cpuTotalTime <- getTotalCPUTime
return $ Just
(procPickStat i psUtimeBox
,procPickStat i psStimeBox
,procPickStat i psCutimeBox
,procPickStat i psCstimeBox
,cpuTotalTime)
Nothing ->
return Nothing
procPickStat :: Format d a => ProcessInfo -> (Int, d, String) -> a
procPickStat infos (index, format, debugInfo) =
maybeError (case infos ?! index of
Just status -> readf format status
Nothing -> Nothing)
$ "parse error : " ++ show debugInfo
toProcessName :: String -> String
toProcessName = filter (`notElem` "()")
toProcessState :: Char -> ProcessState
toProcessState 'R' = Running
toProcessState 'S' = Sleeping
toProcessState 'D' = Waiting
toProcessState 'Z' = Zombie
toProcessState 'T' = Traced
toProcessState 'W' = Paging
toProcessState state = error $ "Miss state : " ++ show state
maybeError :: Maybe a -> String -> a
maybeError m str = fromMaybe (error str) m
(?!) :: [a] -> Int -> Maybe a
[] ?! _ = Nothing
xs ?! n
| n < 0 || n >= length xs
= Nothing
| otherwise
= listToMaybe . drop n $ xs
isIntegerString :: String -> Bool
isIntegerString [] = False
isIntegerString [x] = isDigit x
isIntegerString (x:xs) = isDigit x && isIntegerString xs
getUserDatabase :: IO UserDatabase
getUserDatabase = do
(exitCode, result, _) <- readProcessWithExitCode "getent" ["passwd"] ""
return $ case exitCode of
ExitFailure _ -> M.empty
ExitSuccess ->
M.fromList $
map (\str ->
let (username, rest) = break (== ':') str
(_, uid, _) = rest =~ "[0-9]+" :: (String, String, String)
in (read uid :: Int, username)
) $ lines result
getTotalCPUTime :: IO Int
getTotalCPUTime = do
let filepath = procPath </> procStatFile
Exc.catch
(do
list <- liftM lines $ IO.readFile filepath
if null list
then return 0
else do
let strList = tail $ words $ head list
num = sum $ map (\x -> read x :: Int) strList
return num)
(\(_ :: IOError) -> return 0)
formatFloatN :: Double -> Int -> Double
formatFloatN n d =
fromIntegral (floor $ n * 10 ^ d) / 10 ^ d