module Manatee.Extension.ProcessManager.ProcessView where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.List (findIndex)
import Data.Map (Map)
import Data.Text.Lazy (Text)
import Data.Typeable
import Graphics.UI.Gtk hiding (Statusbar, statusbarNew, get)
import Graphics.UI.Gtk.Gdk.SerializedEvent
import Manatee.Core.PageView
import Manatee.Core.Types
import Manatee.Extension.ProcessManager.ProcessBuffer
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.Functor
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.Process
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.Gtk.Concurrent
import Manatee.Toolkit.Gtk.Gtk
import Manatee.Toolkit.Gtk.ModelView
import Manatee.Toolkit.Gtk.ScrolledWindow
import System.Linux.Proc
import qualified Data.Map as M
data ProcessView =
ProcessView {processViewPlugId :: TVar PagePlugId
,processViewScrolledWindow :: ScrolledWindow
,processViewBuffer :: ProcessBuffer
,processViewTreeView :: TreeView
,processViewListStore :: ListStore ProcStatus
,processViewSortModel :: TypedTreeModelSort ProcStatus
,processViewBroadcastChannel :: ViewChannel ProcTChanSignal
}
deriving Typeable
instance PageBuffer ProcessBuffer where
pageBufferGetName = return . processBufferName
pageBufferSetName _ _ = return ()
pageBufferClient = processBufferClient
pageBufferCreateView a pId = PageViewWrap <$> processViewNew a pId
pageBufferMode = processBufferMode
instance PageView ProcessView where
pageViewBuffer = PageBufferWrap . processViewBuffer
pageViewPlugId = processViewPlugId
pageViewFocus = treeViewFocus . processViewTreeView
pageViewScrolledWindow = processViewScrolledWindow
pageViewHandleKeyAction = processViewHandleKeyAction
pageViewScrollToTop = processViewScrollToTop
pageViewScrollToBottom = processViewScrollToBottom
pageViewScrollVerticalPage = processViewScrollVerticalPage
pageViewScrollVerticalStep = processViewScrollVerticalStep
processViewNew :: ProcessBuffer -> PagePlugId -> IO ProcessView
processViewNew buffer plugId = do
pId <- newTVarIO plugId
scrolledWindow <- scrolledWindowNew_
treeView <- treeViewNew
treeViewSetEnableTreeLines treeView True
scrolledWindow `containerAdd` treeView
listStore <- listStoreNew []
sortModel <- treeModelSortNewWithModel listStore
channel <- createViewChannel (processBufferBroadcastChannel buffer) treeView
let processView = ProcessView pId scrolledWindow buffer treeView listStore sortModel channel
processViewListenChannel processView
counter <- tickTVarIO (processBufferViewCounter buffer)
when (counter == 1) $ processBufferUpdate buffer
treeView `onDestroy` do
crockTVarIO (processBufferViewCounter buffer)
return ()
processViewDraw processView
return processView
processViewListenChannel :: ProcessView -> IO ()
processViewListenChannel view =
listenViewChannel (processViewBroadcastChannel view) $ \signal ->
case signal of
KillProcess index ->
listStoreRemove (processViewListStore view) index
UpdateProcesses -> do
pid <-
treeViewGetSelectedValue (processViewTreeView view)
(processViewSortModel view)
(processViewListStore view)
>?>=> \info ->
return $ Just $ psProcessId info
processViewUpdate view
pid ?>= \id -> do
list <- listStoreToList (processViewListStore view)
findIndex (\x -> psProcessId x == id) list ?>= \ i -> do
path <- treeModelSortConvertChildPathToPath (processViewSortModel view) [i]
treeViewSetCursor (processViewTreeView view) path Nothing
_ -> return ()
processViewDraw :: ProcessView -> IO ()
processViewDraw view = do
let buffer = processViewBuffer view
fileInfos <- readTVarIO $ processBufferStatus buffer
let treeView = processViewTreeView view
store = processViewListStore view
model = processViewSortModel view
listStoreClear store
forM_ fileInfos (listStoreAppend store)
treeViewSetModel treeView model
treeViewRemoveColumns treeView
forM_ (processBufferOptions buffer) (processViewAddColumn treeView store model)
sortStatus <- readTVarIO $ processBufferSortStatus buffer
processViewSortInternal view sortStatus
return ()
processViewUpdate :: ProcessView -> IO ()
processViewUpdate view = do
let store = processViewListStore view
fileInfos <- readTVarIO $ processBufferStatus $ processViewBuffer view
listStoreClear store
forM_ fileInfos (listStoreAppend store)
return ()
processViewSortInternal :: ProcessView -> (ProcOption, SortType) -> IO ()
processViewSortInternal view (option, sortType) = do
let options = processBufferOptions $ processViewBuffer view
lookup option options ?>= \x ->
treeSortableSetSortColumnId (processViewSortModel view) x sortType
processViewAddColumn :: (ProcStatusClass t,
TreeViewClass self1,
TreeModelClass self,
TreeModelSortClass self,
TypedTreeModelClass model,
TreeSortableClass self) =>
self1
-> model ProcStatus
-> self
-> (t, SortColumnId)
-> IO ()
processViewAddColumn treeView model sortModel option@(info,sortId) = do
processViewSetSortFunc model sortModel option
let name = getColumnTitle info
maxWidth = getColumnMaxWidth info
tvc <- treeViewAddColumnWithTitle treeView name sortId
maxWidth ?>= \width -> treeViewColumnSetMaxWidth tvc width
cell <- cellRendererTextNew
treeViewColumnPackStart tvc cell True
processViewSetCellText tvc cell model sortModel info
processViewSetSortFunc :: (TreeSortableClass self,
TypedTreeModelClass model,
ProcStatusClass a) =>
model ProcStatus
-> self
-> (a, SortColumnId)
-> IO ()
processViewSetSortFunc model sortModel (info, sortId) =
treeSortableSetSortFunc sortModel sortId $ \iter1 iter2 -> do
row1 <- treeModelGetRow model iter1
row2 <- treeModelGetRow model iter2
compareRow info row1 row2
processViewSetCellText :: (CellLayoutClass self,
CellRendererTextClass cell,
TreeModelClass model,
TreeModelSortClass model,
TypedTreeModelClass model1,
ProcStatusClass a) =>
self
-> cell
-> model1 ProcStatus
-> model
-> a
-> IO ()
processViewSetCellText tvc cell model sortModel info =
cellLayoutSetAttributeFunc tvc cell sortModel $ \iter -> do
row <- treeModelSortGetRow model sortModel iter
set cell [cellText := getCellText info row
,cellXAlign := getCellXAlign info]
processViewHandleKeyAction :: ProcessView -> Text -> SerializedEvent -> IO ()
processViewHandleKeyAction view keystoke sEvent =
case M.lookup keystoke processViewKeymap of
Just action -> action view
Nothing -> widgetPropagateEvent (processViewTreeView view) sEvent
processViewKeymap :: Map Text (ProcessView -> IO ())
processViewKeymap =
M.fromList
[("j", processViewNextNode)
,("k", processViewPrevNode)
,("Down", processViewNextNode)
,("Up", processViewPrevNode)
,("J", processViewScrollToBottom)
,("K", processViewScrollToTop)
,(" ", processViewScrollVerticalPage True)
,("b", processViewScrollVerticalPage False)
,("PageDown", processViewScrollVerticalPage True)
,("PageUp", processViewScrollVerticalPage False)
,(";", processViewKillProcess)
,("1", processViewSortByName)
,("2", processViewSortByProcessId)
,("3", processViewSortByUser)
,("4", processViewSortByState)
,("5", processViewSortByMemory)
,("6", processViewSortByCPU)
,("7", processViewSortByPriority)
,("8", processViewSortByThreads)
,("9", processViewSortByCmdline)
]
processViewNextNode :: ProcessView -> IO ()
processViewNextNode = treeViewFocusNextToplevelNode . processViewTreeView
processViewPrevNode :: ProcessView -> IO ()
processViewPrevNode = treeViewFocusPrevToplevelNode . processViewTreeView
processViewScrollToTop :: ProcessView -> IO ()
processViewScrollToTop =
treeViewFocusFirstToplevelNode . processViewTreeView
processViewScrollToBottom :: ProcessView -> IO ()
processViewScrollToBottom =
treeViewFocusLastToplevelNode . processViewTreeView
processViewScrollVerticalPage :: Bool -> ProcessView -> IO ()
processViewScrollVerticalPage isDown a = do
let sw = processViewScrolledWindow a
tv = processViewTreeView a
pageInc <- (<=<) adjustmentGetPageIncrement scrolledWindowGetVAdjustment sw
treeViewScrollVertical tv sw (if isDown then pageInc else ( pageInc))
processViewScrollVerticalStep :: Bool -> ProcessView -> IO ()
processViewScrollVerticalStep isDown a = do
let sw = processViewScrolledWindow a
tv = processViewTreeView a
stepInc <- (<<<=) integralToDouble treeViewGetSelectedCellHeight tv
treeViewScrollVertical tv sw (if isDown then stepInc else ( stepInc))
processViewSortByName :: ProcessView -> IO ()
processViewSortByName view = processViewSort view MCommand
processViewSortByUser :: ProcessView -> IO ()
processViewSortByUser view = processViewSort view MUser
processViewSortByProcessId :: ProcessView -> IO ()
processViewSortByProcessId view = processViewSort view MProcessId
processViewSortByState :: ProcessView -> IO ()
processViewSortByState view = processViewSort view MState
processViewSortByParentId :: ProcessView -> IO ()
processViewSortByParentId view = processViewSort view MParentProcessId
processViewSortByGroupId :: ProcessView -> IO ()
processViewSortByGroupId view = processViewSort view MProcessGroupId
processViewSortBySessionId :: ProcessView -> IO ()
processViewSortBySessionId view = processViewSort view MSessionId
processViewSortByPriority :: ProcessView -> IO ()
processViewSortByPriority view = processViewSort view MPriority
processViewSortByThreads :: ProcessView -> IO ()
processViewSortByThreads view = processViewSort view MThreads
processViewSortByCPU :: ProcessView -> IO ()
processViewSortByCPU view = processViewSort view MCPUPercent
processViewSortByMemory :: ProcessView -> IO ()
processViewSortByMemory view = processViewSort view MResidentMemory
processViewSortByCmdline :: ProcessView -> IO ()
processViewSortByCmdline view = processViewSort view MCmdline
processViewSort :: ProcessView -> ProcOption -> IO ()
processViewSort view option = do
let model = processViewSortModel view
buffer = processViewBuffer view
options = processBufferOptions buffer
(curSortType, _, curSortColumnId) <- treeSortableGetSortColumnId model
lookup option options ?>= \id -> do
treeSortableSetSortColumnId model id $
if id == curSortColumnId
then
case curSortType of
SortAscending -> SortDescending
SortDescending -> SortAscending
else SortAscending
(newSortType, _, _) <- treeSortableGetSortColumnId model
writeTVarIO (processBufferSortStatus $ processViewBuffer view) (option, newSortType)
treeViewFocus (processViewTreeView view)
processViewKillProcess :: ProcessView -> IO ()
processViewKillProcess view = do
let treeView = processViewTreeView view
treeViewGetSelectedPath treeView
>?>= \ path -> do
currentPath <- treeModelSortConvertPathToChildPath (processViewSortModel view) path
info <- listStoreGetValue (processViewListStore view) (head currentPath)
let processId = psProcessId info
processName = psCommand info
runCommand_ ("kill " ++ show processId)
processViewRemoveProcess view (head currentPath)
pageViewUpdateOutputStatus view ("Kill process '" ++ processName ++ "' (" ++ show processId ++ ")") Nothing
processViewRemoveProcess :: ProcessView -> Int -> IO ()
processViewRemoveProcess view index =
writeTChanIO (viewChannel $ processViewBroadcastChannel view) (KillProcess index)