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
|
module GUI.StartupInfoView (
StartupInfoView,
startupInfoViewNew,
startupInfoViewSetEvents,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk
import Data.Array
import Data.List
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
-------------------------------------------------------------------------------
data StartupInfoView = StartupInfoView
{ labelProgName :: Label
, storeProgArgs :: ListStore String
, storeProgEnv :: ListStore (String, String)
, labelProgStartTime :: Label
, labelProgRtsId :: Label
}
data StartupInfoState
= StartupInfoEmpty
| StartupInfoLoaded
{ progName :: Maybe String
, progArgs :: Maybe [String]
, progEnv :: Maybe [(String, String)]
, progStartTime :: Maybe UTCTime
, progRtsId :: Maybe String
}
-------------------------------------------------------------------------------
startupInfoViewNew :: Builder -> IO StartupInfoView
startupInfoViewNew builder = do
let getWidget cast = builderGetObject builder cast
labelProgName <- getWidget castToLabel "labelProgName"
treeviewProgArgs <- getWidget castToTreeView "treeviewProgArguments"
treeviewProgEnv <- getWidget castToTreeView "treeviewProgEnvironment"
labelProgStartTime <- getWidget castToLabel "labelProgStartTime"
labelProgRtsId <- getWidget castToLabel "labelProgRtsIdentifier"
storeProgArgs <- listStoreNew []
columnArgs <- treeViewColumnNew
cellArgs <- cellRendererTextNew
treeViewColumnPackStart columnArgs cellArgs True
treeViewAppendColumn treeviewProgArgs columnArgs
treeViewSetModel treeviewProgArgs 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
treeViewSetModel treeviewProgEnv 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 CapEvent) -> 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 CapEvent -> StartupInfoState
processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)
. take 1000
. elems
where
accum info (CapEvent _ (Event _ (ProgramArgs _ (name:args)))) =
info {
progName = Just name,
progArgs = Just args
}
accum info (CapEvent _ (Event _ (ProgramEnv _ env))) =
info { progEnv = Just (sort (parseEnv env)) }
accum info (CapEvent _ (Event _ (RtsIdentifier _ rtsid))) =
info { progRtsId = Just rtsid }
accum info (CapEvent _ (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, '=':value) <- map (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 := "" ]
set labelProgStartTime [ labelText := "" ]
set labelProgRtsId [ labelText := "" ]
listStoreClear storeProgArgs
listStoreClear storeProgEnv
|
