add top for freebsd proc

In FreeBSD /proc/pid/stat is missing we should use for top procstat
library.

4 files changed, 293 insertions, 83 deletions

diff --git a/src/Xmobar/Plugins/Monitors/Top.hs b/src/Xmobar/Plugins/Monitors/Top.hs
index d6df249..e99ec3b 100644
--- a/src/Xmobar/Plugins/Monitors/Top.hs
+++ b/src/Xmobar/Plugins/Monitors/Top.hs
@@ -1,3 +1,5 @@
+{-#LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Plugins.Monitors.Top
@@ -12,24 +14,27 @@
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE BangPatterns #-}
-
 module Xmobar.Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where
 
 import Xmobar.Plugins.Monitors.Common
 
-import Control.Exception (SomeException, handle)
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Data.List (sortBy, foldl')
+import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.List (sortBy)
 import Data.Ord (comparing)
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
-import System.Directory (getDirectoryContents)
-import System.FilePath ((</>))
-import System.IO (IOMode(ReadMode), hGetLine, withFile)
-import System.Posix.Unistd (SysVar(ClockTick), getSysVar)
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+
+import Xmobar.Plugins.Monitors.Top.Common (
+  MemInfo
+  , TimeInfo
+  , Times
+  , TimesRef)
+
+#if defined(freebsd_HOST_OS)
+import qualified Xmobar.Plugins.Monitors.Top.FreeBSD as MT
+#else
+import qualified Xmobar.Plugins.Monitors.Top.Linux as MT
+#endif
 
-import Foreign.C.Types
 
 maxEntries :: Int
 maxEntries = 10
@@ -47,41 +52,6 @@ topConfig = mkMConfig "<both1>"
                                , k <- [ "name", "cpu", "both"
                                       , "mname", "mem", "mboth"]])
 
-foreign import ccall "unistd.h getpagesize"
-  c_getpagesize :: CInt
-
-pageSize :: Float
-pageSize = fromIntegral c_getpagesize / 1024
-
-processes :: IO [FilePath]
-processes = fmap (filter isPid) (getDirectoryContents "/proc")
-  where isPid = (`elem` ['0'..'9']) . head
-
-statWords :: [String] -> [String]
-statWords line@(x:pn:ppn:xs) =
-  if last pn == ')' then line else statWords (x:(pn ++ " " ++ ppn):xs)
-statWords _ = replicate 52 "0"
-
-getProcessData :: FilePath -> IO [String]
-getProcessData pidf =
-  handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords
-  where readWords = fmap (statWords . words) . hGetLine
-        ign = const (return []) :: SomeException -> IO [String]
-
-memPages :: [String] -> String
-memPages fs = fs!!23
-
-ppid :: [String] -> String
-ppid fs = fs!!3
-
-skip :: [String] -> Bool
-skip fs = length fs < 24 || memPages fs == "0" || ppid fs == "0"
-
-handleProcesses :: ([String] -> a) -> IO [a]
-handleProcesses f =
-  fmap (foldl' (\a p -> if skip p then a else f p : a) [])
-       (processes >>= mapM getProcessData)
-
 showInfo :: String -> String -> Float -> Monitor [String]
 showInfo nm sms mms = do
   mnw <- getConfigValue maxWidth
@@ -94,20 +64,10 @@ showInfo nm sms mms = do
   both <- showWithColors' (rnm ++ " " ++ sms) mms
   return [nm, mstr, both]
 
-processName :: [String] -> String
-processName = drop 1 . init . (!!1)
 
 sortTop :: [(String, Float)] -> [(String, Float)]
 sortTop =  sortBy (flip (comparing snd))
 
-type MemInfo = (String, Float)
-
-meminfo :: [String] -> MemInfo
-meminfo fs = (processName fs, pageSize * parseFloat (fs!!23))
-
-meminfos :: IO [MemInfo]
-meminfos = handleProcesses meminfo
-
 showMemInfo :: Float -> MemInfo -> Monitor [String]
 showMemInfo scale (nm, rss) =
   showInfo nm (showWithUnits 3 1 rss) (100 * rss / sc)
@@ -117,30 +77,8 @@ showMemInfos :: [MemInfo] -> Monitor [[String]]
 showMemInfos ms = mapM (showMemInfo tm) ms
   where tm = sum (map snd ms)
 
-runTopMem :: [String] -> Monitor String
-runTopMem _ = do
-  mis <- io meminfos
-  pstr <- showMemInfos (sortTop mis)
-  parseTemplate $ concat pstr
-
-type Pid = Int
-type TimeInfo = (String, Float)
-type TimeEntry = (Pid, TimeInfo)
-type Times = [TimeEntry]
-type TimesRef = IORef (Times, UTCTime)
-
-timeMemEntry :: [String] -> (TimeEntry, MemInfo)
-timeMemEntry fs = ((p, (n, t)), (n, r))
-  where p = parseInt (head fs)
-        n = processName fs
-        t = parseFloat (fs!!13) + parseFloat (fs!!14)
-        (_, r) = meminfo fs
-
-timeMemEntries :: IO [(TimeEntry, MemInfo)]
-timeMemEntries = handleProcesses timeMemEntry
-
 timeMemInfos :: IO (Times, [MemInfo], Int)
-timeMemInfos = fmap res timeMemEntries
+timeMemInfos = fmap res MT.timeMemEntries
   where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x)
 
 combine :: Times -> Times -> Times
@@ -164,7 +102,7 @@ topProcesses tref scale = do
   c1 <- getCurrentTime
   let scx = realToFrac (diffUTCTime c1 c0) * scale
       !scx' = if scx > 0 then scx else scale
-      nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1)
+      nts = map (\(_, (nm, t)) -> (nm, t / scx')) (combine t0 t1)
       !t1' = take' (length t1) t1
       !nts' = take' maxEntries (sortTop nts)
       !mis' = take' maxEntries (sortTop mis)
@@ -178,6 +116,12 @@ showTimeInfo (n, t) =
 showTimeInfos :: [TimeInfo] -> Monitor [[String]]
 showTimeInfos = mapM showTimeInfo
 
+runTopMem :: [String] -> Monitor String
+runTopMem _ = do
+  mis <- io MT.meminfos
+  pstr <- showMemInfos (sortTop mis)
+  parseTemplate $ concat pstr
+
 runTop :: TimesRef -> Float -> [String] -> Monitor String
 runTop tref scale _ = do
   (no, ps, ms) <- io $ topProcesses tref scale
@@ -187,9 +131,8 @@ runTop tref scale _ = do
 
 startTop :: [String] -> Int -> (String -> IO ()) -> IO ()
 startTop a r cb = do
-  cr <- getSysVar ClockTick
   c <- getCurrentTime
   tref <- newIORef ([], c)
-  let scale = fromIntegral cr / 100
+  scale <- MT.scale
   _ <- topProcesses tref scale
   runM a topConfig (runTop tref scale) r cb
diff --git a/src/Xmobar/Plugins/Monitors/Top/Common.hs b/src/Xmobar/Plugins/Monitors/Top/Common.hs
new file mode 100644
index 0000000..74b6fdd
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Top/Common.hs
@@ -0,0 +1,32 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.Top.Common
+-- Copyright   :  (c) 2010, 2011, 2012, 2013, 2014, 2018 Jose A Ortega Ruiz
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+--  Process activity and memory consumption monitors
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Top.Common (
+  MemInfo
+  , Pid
+  , TimeInfo
+  , TimeEntry
+  , Times
+  , TimesRef
+  ) where
+
+import Data.IORef (IORef)
+import Data.Time.Clock (UTCTime)
+
+type MemInfo = (String, Float)
+type Pid = Int
+type TimeInfo = (String, Float)
+type TimeEntry = (Pid, TimeInfo)
+type Times = [TimeEntry]
+type TimesRef = IORef (Times, UTCTime)
diff --git a/src/Xmobar/Plugins/Monitors/Top/FreeBSD.hsc b/src/Xmobar/Plugins/Monitors/Top/FreeBSD.hsc
new file mode 100644
index 0000000..cb822ef
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Top/FreeBSD.hsc
@@ -0,0 +1,143 @@
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CApiFFI #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.Top.FreeBSD
+-- Copyright   :  (c) 2010, 2011, 2012, 2013, 2014, 2018 Jose A Ortega Ruiz
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+--  Process activity and memory consumption monitors
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Top.FreeBSD (
+  timeMemEntries
+  , meminfos
+  , scale) where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+
+import Xmobar.Plugins.Monitors.Top.Common (MemInfo, TimeEntry)
+
+#include <unistd.h>
+#include <sys/sysctl.h>
+#include <sys/user.h>
+#include <libprocstat.h>
+
+foreign import ccall "unistd.h getpagesize" c_getpagesize :: CInt
+foreign import ccall unsafe "libprocstat.h procstat_open_sysctl" c_procstat_open_sysctl :: IO (Ptr PROCSTAT)
+foreign import ccall "&procstat_close" c_procstat_close :: FinalizerPtr PROCSTAT
+foreign import ccall "&procstat_freeprocs" c_procstat_freeprocs :: FinalizerEnvPtr PROCSTAT KINFO_PROC
+foreign import ccall unsafe "libprocstat.h procstat_getprocs" c_procstat_getprocs :: Ptr PROCSTAT -> CInt -> CInt -> Ptr CUInt -> IO (Ptr KINFO_PROC)
+
+data PROCSTAT
+data ProcStat = ProcStat !(ForeignPtr PROCSTAT)
+  deriving (Eq, Ord, Show)
+
+data KINFO_PROC
+data KinfoProc = KinfoProc [ProcData] Int
+  deriving (Eq, Show)
+
+data ProcData = ProcData {
+  pname :: String
+  , cpu :: Float
+  , tdflags :: CULong
+  , flag :: CULong
+  , stat :: CUChar
+  , rss :: Float
+  , pid :: Int
+  , runtime :: Float
+  }
+  deriving (Show, Read, Eq)
+
+instance Storable ProcData where
+  alignment _ = #{alignment struct kinfo_proc}
+  sizeOf _    = #{size struct kinfo_proc}
+  peek ptr    = do
+       c <- #{peek struct kinfo_proc, ki_pctcpu} ptr
+       ctdflags <- #{peek struct kinfo_proc, ki_tdflags} ptr
+       cflag <- #{peek struct kinfo_proc, ki_flag} ptr
+       cstat <- #{peek struct kinfo_proc, ki_stat} ptr
+       cruntime <- #{peek struct kinfo_proc, ki_runtime} ptr :: IO CULong
+       crss <- #{peek struct kinfo_proc, ki_rssize} ptr :: IO CULong
+       cname <- peekCString (ptr `plusPtr` (#offset struct kinfo_proc, ki_comm))
+       cpid <- #{peek struct kinfo_proc, ki_pid} ptr
+       let crssf = (fromIntegral . toInteger) crss
+       let cruntimef = ((fromIntegral . toInteger) cruntime  + 500000) / 10000
+       return $ ProcData {
+         pname = cname
+         , cpu = (pctdouble c) * 100
+         , tdflags = ctdflags
+         , stat = cstat
+         , flag = cflag
+         , rss = crssf * pageSize
+         , pid = cpid
+         , runtime = cruntimef}
+
+  poke _ _    = pure ()
+
+pctdouble :: Int -> Float
+pctdouble p = (fromIntegral p) / #{const FSCALE}
+
+
+pageSize :: Float
+pageSize = fromIntegral c_getpagesize / 1024
+
+
+getProcStat:: IO ProcStat
+getProcStat = do
+    proc_ptr <- c_procstat_open_sysctl
+    ptr <- newForeignPtr c_procstat_close proc_ptr
+    return $ ProcStat ptr
+
+
+getProcessesInfo :: ProcStat -> IO [ProcData]
+getProcessesInfo (ProcStat ps_fp) = do
+  withForeignPtr ps_fp $ \ps_ptr -> do
+    alloca $ \n_ptr -> do
+      kinfo_proc_ptr <- c_procstat_getprocs ps_ptr #{const KERN_PROC_PROC} 0 n_ptr
+      newForeignPtrEnv c_procstat_freeprocs ps_ptr kinfo_proc_ptr
+      num <- peek (n_ptr :: Ptr CUInt)
+      pds <- peekArray (fromIntegral num) $ castPtr kinfo_proc_ptr :: IO [ProcData]
+
+      return $ [p | p <- pds, flag p .&. #{const P_SYSTEM} == 0]
+
+
+processes :: IO [ProcData]
+processes = do
+  proc_stat <- getProcStat
+  getProcessesInfo proc_stat
+
+handleProcesses :: (ProcData -> a) -> IO [a]
+handleProcesses f = do
+  ps <- processes
+  return $ fmap (\pd -> f pd) ps
+
+meminfo :: ProcData -> MemInfo
+meminfo pd = (pname pd, rss pd)
+
+meminfos :: IO [MemInfo]
+meminfos = handleProcesses meminfo
+
+timeMemEntry :: ProcData -> (TimeEntry, MemInfo)
+timeMemEntry pd = ((p, (n, t)), (n, r))
+  where p = pid pd
+        n = pname pd
+        t = runtime pd
+        (_, r) = meminfo pd
+
+timeMemEntries :: IO [(TimeEntry, MemInfo)]
+timeMemEntries = handleProcesses timeMemEntry
+
+scale :: IO Float
+scale = return 1
diff --git a/src/Xmobar/Plugins/Monitors/Top/Linux.hs b/src/Xmobar/Plugins/Monitors/Top/Linux.hs
new file mode 100644
index 0000000..715a7cd
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Top/Linux.hs
@@ -0,0 +1,92 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.Top.Linux
+-- Copyright   :  (c) 2010, 2011, 2012, 2013, 2014, 2018 Jose A Ortega Ruiz
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+--  Process activity and memory consumption monitors
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Xmobar.Plugins.Monitors.Top.Linux (
+  timeMemEntries
+  , meminfos
+  , scale) where
+
+import Xmobar.Plugins.Monitors.Common (parseFloat, parseInt)
+import Xmobar.Plugins.Monitors.Top.Common (MemInfo, TimeEntry)
+
+import Control.Exception (SomeException, handle)
+import Data.List (foldl')
+import System.Directory (getDirectoryContents)
+import System.FilePath ((</>))
+import System.IO (IOMode(ReadMode), hGetLine, withFile)
+import System.Posix.Unistd (SysVar(ClockTick), getSysVar)
+
+import Foreign.C.Types
+
+foreign import ccall "unistd.h getpagesize"
+  c_getpagesize :: CInt
+
+pageSize :: Float
+pageSize = fromIntegral c_getpagesize / 1024
+
+processes :: IO [FilePath]
+processes = fmap (filter isPid) (getDirectoryContents "/proc")
+  where isPid = (`elem` ['0'..'9']) . head
+
+statWords :: [String] -> [String]
+statWords line@(x:pn:ppn:xs) =
+  if last pn == ')' then line else statWords (x:(pn ++ " " ++ ppn):xs)
+statWords _ = replicate 52 "0"
+
+getProcessData :: FilePath -> IO [String]
+getProcessData pidf =
+  handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords
+  where readWords = fmap (statWords . words) . hGetLine
+        ign = const (return []) :: SomeException -> IO [String]
+
+memPages :: [String] -> String
+memPages fs = fs!!23
+
+ppid :: [String] -> String
+ppid fs = fs!!3
+
+skip :: [String] -> Bool
+skip fs = length fs < 24 || memPages fs == "0" || ppid fs == "0"
+
+handleProcesses :: ([String] -> a) -> IO [a]
+handleProcesses f =
+  fmap (foldl' (\a p -> if skip p then a else f p : a) [])
+       (processes >>= mapM getProcessData)
+
+processName :: [String] -> String
+processName = drop 1 . init . (!!1)
+
+meminfo :: [String] -> MemInfo
+meminfo fs = (processName fs, pageSize * parseFloat (fs!!23))
+
+meminfos :: IO [MemInfo]
+meminfos = handleProcesses meminfo
+
+timeMemEntry :: [String] -> (TimeEntry, MemInfo)
+timeMemEntry fs = ((p, (n, t)), (n, r))
+  where p = parseInt (head fs)
+        n = processName fs
+        t = parseFloat (fs!!13) + parseFloat (fs!!14)
+        (_, r) = meminfo fs
+
+timeMemEntries :: IO [(TimeEntry, MemInfo)]
+timeMemEntries = handleProcesses timeMemEntry
+
+
+scale :: IO Float
+scale = do
+  cr <- getSysVar ClockTick
+  return $ fromIntegral cr / 100