File: StartupInfoView.hs

package info (click to toggle)
threadscope 0.2.14.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 580 kB
  • sloc: haskell: 5,457; ansic: 10; makefile: 7
file content (150 lines) | stat: -rw-r--r-- 5,594 bytes parent folder | download | duplicates (2)
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