Proc.hs

{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}
-- 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.Exception
import Control.Monad
import Data.Char
import Data.Int
import Data.Maybe
import Data.Word
import System.Directory
import System.FilePath
import System.Posix.Types
import System.IO.Error
import System.IO
import Text.XFormat.Read

import qualified Control.Exception as Exc

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 (Maybe ProcStatus)
procGetProcessStatus pid = do
  info <- procGetProcessInfo pid
  return $ case info of 
             Just i  -> Just $ procParseStatus i
             Nothing -> Nothing

-- | Get information for all running processes.
procGetAllProcessStatus :: IO [ProcStatus]
procGetAllProcessStatus = do
    dirs <- procGetProcessDirs
    status <- mapM (\pid -> procGetProcessStatus (read pid :: ProcessID)) dirs
    return $ catMaybes status

-- | Get process status with given process id.
procGetProcessInfo :: ProcessID -> IO (Maybe ProcessInfo)
procGetProcessInfo pid = do
  let filepath = procPath </> show pid </> procStatFile
  Exc.catch 
     (liftM (Just . words) $ readFile filepath)
     (\(_ :: IOError) -> return Nothing) -- skip current file if failed with `readFile`

-- | 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