summaryrefslogtreecommitdiffhomepage
path: root/Plugins/Monitors/Top.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Plugins/Monitors/Top.hs')
-rw-r--r--Plugins/Monitors/Top.hs66
1 files changed, 39 insertions, 27 deletions
diff --git a/Plugins/Monitors/Top.hs b/Plugins/Monitors/Top.hs
index 08c2da1..e83e94b 100644
--- a/Plugins/Monitors/Top.hs
+++ b/Plugins/Monitors/Top.hs
@@ -19,8 +19,8 @@ module Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where
import Plugins.Monitors.Common
import Control.Exception (SomeException, handle)
-import Data.IORef (IORef, newIORef, atomicModifyIORef)
-import Data.List (sortBy)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (sortBy, foldl')
import Data.Ord (comparing)
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import System.Directory (getDirectoryContents)
@@ -30,11 +30,11 @@ import System.Posix.Unistd (SysVar(ClockTick), getSysVar)
import Foreign.C.Types
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as M
+maxEntries :: Int
+maxEntries = 10
intStrs :: [String]
-intStrs = map show [(1::Int) ..]
+intStrs = map show [1..maxEntries]
topMemConfig :: IO MConfig
topMemConfig = mkMConfig "<both1>"
@@ -64,19 +64,22 @@ showInfo nm sms mms = do
both <- showWithColors' (rnm ++ " " ++ sms) mms
return [nm, mstr, both]
+ignoreErrors :: IO [String] -> IO [String]
+ignoreErrors = handle returnEmpty
+ where returnEmpty = const (return []) :: SomeException -> IO [String]
+
processes :: IO [FilePath]
-processes = fmap (filter isPid) (getDirectoryContents "/proc")
- where isPid = all (`elem` ['0'..'9'])
+processes = ignoreErrors $ fmap (filter isPid) (getDirectoryContents "/proc")
+ where isPid = (`elem` ['0'..'9']) . head
getProcessData :: FilePath -> IO [String]
getProcessData pidf =
- handle (const (return []) :: SomeException -> IO [String])
- (withFile ("/proc" </> pidf </> "stat") ReadMode readWords)
+ ignoreErrors $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords
where readWords = fmap words . hGetLine
handleProcesses :: ([String] -> a) -> IO [a]
handleProcesses f =
- fmap (foldr (\p ps -> if p == [] then ps else f p : ps) [])
+ fmap (foldl' (\a p -> if null p then a else f p : a) [])
(processes >>= mapM getProcessData)
processName :: [String] -> String
@@ -110,7 +113,7 @@ runTopMem _ = do
type Pid = Int
type TimeInfo = (String, Float)
type TimeEntry = (Pid, TimeInfo)
-type Times = IntMap TimeInfo
+type Times = [TimeEntry]
type TimesRef = IORef (Times, UTCTime)
timeMemEntry :: [String] -> (TimeEntry, Meminfo)
@@ -125,37 +128,46 @@ timeMemEntries = handleProcesses timeMemEntry
timeMemInfos :: IO (Times, [Meminfo], Int)
timeMemInfos =
- fmap (\x -> (M.fromList . map fst $ x, map snd x, length x)) timeMemEntries
+ fmap (\x -> (sortPids $ map fst x, map snd x, length x)) timeMemEntries
+ where sortPids = sortBy (comparing fst)
-combineTimeInfos :: Times -> Times -> Times
-combineTimeInfos t0 t1 = M.intersectionWith timeDiff t1 t0
- where timeDiff (n, x1) (_, x0) = (n, x1 - x0)
+combine :: Times -> Times -> Times
+combine _ [] = []
+combine [] t = t
+combine l@((p0, (n0, t0)):xs) r@((p1, (n1, t1)):ys)
+ | p0 == p1 = (p0, (n0, t1 - t0)) : combine xs ys
+ | p0 < p1 = combine xs r
+ | otherwise = (p1, (n1, t1)) : combine l ys
topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [Meminfo])
topProcesses tref scale = do
- (t1, mis, len) <- timeMemInfos
+ (t0, c0) <- readIORef tref
+ (t1', mis, len) <- timeMemInfos
c1 <- getCurrentTime
- atomicModifyIORef tref $ \(t0, c0) ->
- let scx = realToFrac (diffUTCTime c1 c0) * scale / 100
- -- c0 and c1 can be equal, for instance, if we tweak the clock
- !scx' = if scx > 0 then scx else scale / 100
- ts = M.elems $ combineTimeInfos t0 t1
- nts = map (\(nm, t) -> (nm, min 100 (t / scx'))) ts
- in ((t1, c1), (len, sortTop nts, mis))
+ let !t1 = t1'
+ writeIORef tref (t1, c1)
+ let scx = realToFrac (diffUTCTime c1 c0) * scale
+ -- c0 and c1 can be equal, for instance, if we tweak the clock
+ !scx' = if scx > 0 then scx else scale
+ ts = combine t0 t1
+ nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) ts
+ return (len, sortTop nts, mis)
showTimeInfo :: TimeInfo -> Monitor [String]
-showTimeInfo (n, t) = showInfo n (showDigits 1 t) t
+showTimeInfo (n, t) = showInfo n (showDigits 0 t) t
runTop :: TimesRef -> Float -> [String] -> Monitor String
runTop tref scale _ = do
(no, ps, ms) <- io $ topProcesses tref scale
pstr <- mapM showTimeInfo ps
mstr <- showMeminfos ms
- parseTemplate $! show no : concat (zipWith (++) pstr mstr)
+ let !pstr' = take maxEntries pstr
+ !mstr' = take maxEntries mstr
+ parseTemplate $! show no : concat (zipWith (++) pstr' mstr')
startTop :: [String] -> Int -> (String -> IO ()) -> IO ()
startTop a r cb = do
cr <- getSysVar ClockTick
c <- getCurrentTime
- tref <- newIORef (M.empty, c)
- runM a topConfig (runTop tref (fromIntegral cr)) r cb
+ tref <- newIORef ([], c)
+ runM a topConfig (runTop tref (fromIntegral cr / 100)) r cb