From 7d4d754f92a3c0f78f4adc474392013749d85972 Mon Sep 17 00:00:00 2001
From: Jose A Ortega Ruiz <jao@gnu.org>
Date: Sun, 14 Feb 2010 04:08:23 +0100
Subject: Less resource hungry top monitors

Ignore-this: 920f60d81166f87370d20d779ed738c9

darcs-hash:20100214030823-748be-bde07719a3b3658a63bb1b687fec6c4c74b1f566.gz
---
 Plugins/Monitors/Top.hs | 78 +++++++++++++++++++++++++++++++------------------
 1 file changed, 49 insertions(+), 29 deletions(-)

(limited to 'Plugins/Monitors/Top.hs')

diff --git a/Plugins/Monitors/Top.hs b/Plugins/Monitors/Top.hs
index 38686f6..6ca75c7 100644
--- a/Plugins/Monitors/Top.hs
+++ b/Plugins/Monitors/Top.hs
@@ -21,6 +21,7 @@ import Plugins.Monitors.Common
 import Control.Exception (SomeException, handle, evaluate)
 import System.Directory
 import System.FilePath
+import System.IO
 import System.Posix.Unistd (getSysVar, SysVar(ClockTick))
 import Foreign.C.Types
 import Data.List (sortBy)
@@ -40,19 +41,13 @@ topCpuConfig = mkMConfig "<both1>" [ k ++ n | n <- map show [1..maxProc]
                                             , k <- ["name", "cpu", "both"]]
 
 
+
 foreign import ccall "unistd.h getpagesize"
   c_getpagesize :: CInt
 
 pageSize :: Int
 pageSize = fromIntegral c_getpagesize `div` 1024
 
-processes :: IO [FilePath]
-processes =
-  fmap (filter isPid) $ getDirectoryContents "/proc"
-  where
-    isPid (x:_) = x `elem` ['0'..'9']
-    isPid _ = False
-
 showInfo :: String -> String -> Float -> Monitor [String]
 showInfo nm sms mms = do
   mnw <- getConfigValue maxWidth
@@ -65,29 +60,53 @@ showInfo nm sms mms = do
   both <- showWithColors' (rnm ++ " " ++ sms) mms
   return [nm, mstr, both]
 
-defHandle :: a -> SomeException -> IO a
-defHandle def _ = evaluate def
+strictReadFile :: FilePath -> IO String
+strictReadFile f =
+  do hdl <- openFile f ReadMode
+     xs <- getc hdl
+     hClose hdl
+     return xs
+    where getc hdl = do e <- hIsEOF hdl
+                        if e then return []
+                          else do c <- hGetChar hdl
+                                  cs <- getc hdl
+                                  return (c:cs)
+
+getProcessData :: FilePath -> IO [String]
+getProcessData pidf =
+  handle ((\_ -> evaluate []) :: SomeException -> IO [String])
+         (do s <- strictReadFile $ "/proc" </> pidf </> "stat"
+             evaluate $ words $! s)
 
-handlePidFile :: a -> ([String] -> IO a) -> FilePath -> IO a
-handlePidFile def action pidf =
-  handle (defHandle def) (fmap words (readFile f) >>= action)
-  where f = "/proc" </> pidf </> "stat"
+processes :: IO [FilePath]
+processes = do
+  fs <- getDirectoryContents "/proc"
+  return $! filter isPid $! fs
+  where
+    isPid (x:_) = x `elem` ['0'..'9']
+    isPid _ = False
+
+handleProcesses :: a -> ([String] -> a) -> IO [a]
+handleProcesses def f = do
+  ps <- processes
+  pd <- mapM getProcessData $! ps
+  return $! map (\x -> if x == [] then def else f x) pd
+
+processName :: [String] -> String
+processName = drop 1 . init . (!!1)
 
 maxProc :: Int
 maxProc = 5
 
 type Meminfo = (String, Int)
 
-meminfo :: FilePath -> IO Meminfo
-meminfo = handlePidFile ("", 0) $ \fs ->
-  let !m = pageSize * read (fs !! 23)
-      !n = drop 1 $ init (fs !! 1)
-  in evaluate (n, m)
+meminfo :: [String] -> Meminfo
+meminfo fs = (n, r)
+  where !n = processName fs
+        !r = pageSize * (read (fs!!23))
 
 meminfos :: IO [Meminfo]
-meminfos = do
-  fs <- processes
-  mapM meminfo fs
+meminfos = handleProcesses ("", 0) meminfo
 
 topMemProcesses :: Int -> IO [Meminfo]
 topMemProcesses n = fmap (take n . sbm) meminfos
@@ -111,16 +130,17 @@ type TimeEntry = (Pid, TimeInfo)
 type Times = IntMap TimeInfo
 type TimesRef = IORef Times
 
-timeEntry :: FilePath -> IO TimeEntry
-timeEntry = handlePidFile (0, ("", 0)) $ \fs ->
-  let rf = read . (fs!!)
-      !pid = read (head fs)
-      !n = drop 1 $ init (fs!!1)
-      !t = rf 13 + rf 14
-  in evaluate (pid, (n, t))
+timeEntry :: [String] -> TimeEntry
+timeEntry fs = (p, (n, t))
+  where !p = read (head fs)
+        !n = processName fs
+        !t = read (fs!!13) + read (fs!!14)
+
+timeEntries :: IO [TimeEntry]
+timeEntries = handleProcesses (0, ("", 0)) timeEntry
 
 timeinfos :: IO Times
-timeinfos = fmap M.fromList (processes >>= mapM timeEntry)
+timeinfos = fmap M.fromList timeEntries
 
 combineTimeInfos :: Times -> Times -> Times
 combineTimeInfos !t0 !t1 = M.intersectionWith timeDiff t1 t0
-- 
cgit v1.2.3