Proc.hs

{-# LANGUAGE TypeOperators #-}
-- This library is for parse information from /proc on Linux.
module System.Linux.Proc (
-- * Types
    ProcessName,  
    ProcessState (..),
    ProcStatus (..),

-- * Methods
    procGetProcessDirs,
    procGetProcessStatus,
    procGetAllProcessStatus
    ) where

import Control.Applicative
import Control.Monad
import Data.Char
import Data.Word
import Data.Int
import Data.Maybe
import System.Directory
import System.FilePath
import Text.XFormat.Read
import System.Posix.Types

type ProcessName = String
type ProcessInfo = [String]
data ProcessState = Running
                  | Sleeping
                  | Waiting
                  | Zombie
                  | Traced
                  | Paging
                    deriving (Show, Read, Ord, Eq)

data ProcStatus = 
    ProcStatus {psProcessId      :: Int          -- The process ID.
               ,psCommand        :: String       -- The  filename of the executable
               ,psState          :: ProcessState -- Process state
               ,psParentProcessId:: Int          -- The PID of the parent
               ,psProcessGroupId :: Int          -- The process group ID of the process
               ,psSessionId      :: Int          -- The session ID of the process
               } deriving (Show, Read, Ord, Eq)

-- | Path for /proc.
procPath :: FilePath
procPath = "/proc"

-- | Status file about the process, 
procStatFile :: FilePath
procStatFile = "stat"

-- | Information Box to find status.
psProcessIdBox        = (0, Int,      "psProcessId")
psCommandBox          = (1, String,   "psCommand")
psStateBox            = (2, Char,     "psState")
psParentProcessIdBox  = (3, Int,      "psParentProcessIdBox")
psProcessGroupIdBox   = (4, Int,      "psProcessGroupIdBox")
psSessionIdBox        = (5, Int,      "psSessionId")

-- | Get process directories.
procGetProcessDirs :: IO [FilePath]
procGetProcessDirs = 
    -- Get directory contents.
    getDirectoryContents procPath
    -- Filter sub-directories.
    >>= filterM (\x -> doesDirectoryExist $ procPath </> x) 
    -- Filter integer directories.
    >>= \dirs -> return $ filter isIntegerString dirs

-- | Get process status with given process id.
procGetProcessStatus :: ProcessID -> IO ProcStatus
procGetProcessStatus pid = liftM procParseStatus $ procGetProcessInfo pid

-- | Get information for all running processes.
procGetAllProcessStatus :: IO [ProcStatus]
procGetAllProcessStatus = 
    procGetProcessDirs
    >>= mapM (\pid -> procGetProcessStatus (read pid :: ProcessID))

-- | Get process status with given process id.
procGetProcessInfo :: ProcessID -> IO ProcessInfo
procGetProcessInfo pid =
    liftM words $ readFile $ procPath </> show pid </> procStatFile

-- | Parse status from given info.
procParseStatus :: ProcessInfo -> ProcStatus
procParseStatus info = 
    ProcStatus pid (toProcessName comm) (toProcessState state) ppid pgid sid
    where pid   = procFindStatus info psProcessIdBox
          comm  = procFindStatus info psCommandBox  
          state = procFindStatus info psStateBox    
          ppid  = procFindStatus info psParentProcessIdBox
          pgid  = procFindStatus info psProcessGroupIdBox 
          sid   = procFindStatus info psSessionIdBox      

-- | Find status from given info.
-- Throw error if parse failed.
procFindStatus :: Format d a => ProcessInfo -> (Int, d, String) -> a 
procFindStatus infos (index, format, debugInfo) = 
  maybeError (case infos ?! index of
                Just status -> readf format status
                Nothing     -> Nothing)
             $ "parse error : " ++ show debugInfo

-- | To Process name.
toProcessName :: String -> String
toProcessName = filter (`notElem` "()")

-- | To process state.
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

-- | Indicate error or return a.
-- This function for replace `fromJust`, expression `fromJust x` is bad
-- when `x` is `Nothing`, so `maybeError` allowed you customize error
-- informatiron.
maybeError :: Maybe a -> String -> a
maybeError m str = fromMaybe (error str) m

-- | Return element of list with given index.
(?!) :: [a] -> Int -> Maybe a
[] ?! _ = Nothing              
xs ?! n
    | n < 0 || n >= length xs 
        = Nothing
    | otherwise               
        = listToMaybe . drop n $ xs

-- | Is integer string? 
isIntegerString :: String -> Bool
isIntegerString []     = False
isIntegerString [x]    = isDigit x
isIntegerString (x:xs) = isDigit x && isIntegerString xs