1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module GUI.StartupInfoView (
StartupInfoView,
startupInfoViewNew,
startupInfoViewSetEvents,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Data.Array
import Data.List
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
import Data.Text (Text)
import qualified Data.Text as T
-------------------------------------------------------------------------------
data StartupInfoView = StartupInfoView
{ labelProgName :: Label
, storeProgArgs :: ListStore Text
, storeProgEnv :: ListStore (Text, Text)
, labelProgStartTime :: Label
, labelProgRtsId :: Label
}
data StartupInfoState
= StartupInfoEmpty
| StartupInfoLoaded
{ progName :: Maybe Text
, progArgs :: Maybe [Text]
, progEnv :: Maybe [(Text, Text)]
, progStartTime :: Maybe UTCTime
, progRtsId :: Maybe Text
}
-------------------------------------------------------------------------------
startupInfoViewNew :: Builder -> IO StartupInfoView
startupInfoViewNew builder = do
let getWidget cast = builderGetObject builder cast
labelProgName <- getWidget castToLabel ("labelProgName" :: Text)
treeviewProgArgs <- getWidget castToTreeView ("treeviewProgArguments" :: Text)
treeviewProgEnv <- getWidget castToTreeView ("treeviewProgEnvironment" :: Text)
labelProgStartTime <- getWidget castToLabel ("labelProgStartTime" :: Text)
labelProgRtsId <- getWidget castToLabel ("labelProgRtsIdentifier" :: Text)
storeProgArgs <- listStoreNew []
columnArgs <- treeViewColumnNew
cellArgs <- cellRendererTextNew
treeViewColumnPackStart columnArgs cellArgs True
treeViewAppendColumn treeviewProgArgs columnArgs
Compat.treeViewSetModel treeviewProgArgs (Just storeProgArgs)
set cellArgs [ cellTextEditable := True ]
cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \arg ->
[ cellText := arg ]
storeProgEnv <- listStoreNew []
columnVar <- treeViewColumnNew
cellVar <- cellRendererTextNew
columnValue <- treeViewColumnNew
cellValue <- cellRendererTextNew
treeViewColumnPackStart columnVar cellVar False
treeViewColumnPackStart columnValue cellValue True
treeViewAppendColumn treeviewProgEnv columnVar
treeViewAppendColumn treeviewProgEnv columnValue
Compat.treeViewSetModel treeviewProgEnv (Just storeProgEnv)
cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \(var,_) ->
[ cellText := var ]
set cellValue [ cellTextEditable := True ]
cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \(_,value) ->
[ cellText := value ]
let startupInfoView = StartupInfoView{..}
return startupInfoView
-------------------------------------------------------------------------------
startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int Event) -> IO ()
startupInfoViewSetEvents view mevents =
updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents)
--TODO: none of this handles the possibility of an eventlog containing multiple
-- OS processes. Note that the capset arg is ignored in the events below.
processEvents :: Array Int Event -> StartupInfoState
processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)
. take 1000
. elems
where
accum info (Event _ (ProgramArgs _ (name:args)) _) =
info {
progName = Just name,
progArgs = Just args
}
accum info (Event _ (ProgramEnv _ env) _) =
info { progEnv = Just (sort (parseEnv env)) }
accum info (Event _ (RtsIdentifier _ rtsid) _) =
info { progRtsId = Just rtsid }
accum info (Event timestamp (WallClockTime _ sec nsec) _) =
-- WallClockTime records the wall clock time of *this* event
-- which occurs some time after startup, so we can just subtract
-- the timestamp since that is the relative time since startup.
let wallTimePosix :: NominalDiffTime
wallTimePosix = fromIntegral sec
+ (fromIntegral nsec / nanoseconds)
- (fromIntegral timestamp / nanoseconds)
nanoseconds = 1000000000
wallTimeUTC = posixSecondsToUTCTime wallTimePosix
in info { progStartTime = Just wallTimeUTC }
accum info _ = info
-- convert ["foo=bar", ...] to [("foo", "bar"), ...]
parseEnv env = [ (var, value) | (var, T.drop 1 -> value) <- map (T.span (/='=')) env ]
updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()
updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do
set labelProgName [ labelText := fromMaybe "(unknown)" progName ]
set labelProgStartTime [ labelText := maybe "(unknown)" show progStartTime ]
set labelProgRtsId [ labelText := fromMaybe "(unknown)" progRtsId ]
listStoreClear storeProgArgs
mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs)
listStoreClear storeProgEnv
mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)
updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do
set labelProgName [ labelText := ("" :: Text) ]
set labelProgStartTime [ labelText := ("" :: Text) ]
set labelProgRtsId [ labelText := ("" :: Text) ]
listStoreClear storeProgArgs
listStoreClear storeProgEnv
|
