Filter events.

client/src/App.svelte

@@ -5,9 +5,11 @@
   let name = 'world';
   let response;
   let restResponse = '';
-  let eventlogFilepath = '/home/csaba/haskell/lambdacube-quake3/q3mapviewer.eventlog';
-  // let eventlogFilepath = '/home/andorp/Sources/grin-tech/grin/grin.eventlog';
+  // let eventlogFilepath = '/home/csaba/haskell/lambdacube-quake3/q3mapviewer.eventlog';
+  let eventlogFilepath = '/home/andorp/Sources/grin-tech/grin/grin.eventlog';
   let eventlog;
+  let eventLogOffset = 0;
+  let eventLogIdx = 10000;
 
   onMount(() => restTest());
 
@@ -39,7 +41,8 @@
   let el, el2, el3, el4;
 
   async function restTest() {
-    let uri = `http://localhost:3000/eventlog/${btoa(eventlogFilepath)}?offset=0&idx=10000`;
+    // let uri = `http://localhost:3000/eventlog/${btoa(eventlogFilepath)}?offset=0&idx=10000`;
+    let uri = `http://localhost:3000/eventlog/${btoa(eventlogFilepath)}?event-type=HeapAllocated&event-type=HeapSize&event-type=HeapLive`;
     console.log("send:", uri);
     let response = await fetch(uri);
     let data = await response.json();

server/EventlogJSON.hs

@@ -9,6 +9,7 @@ import qualified Data.ByteString.Base64 as Base64
 
 import GHC.RTS.Events as GHC
 
+
 instance FromJSON BS.ByteString where
   parseJSON a = parseJSON a >>= either fail pure . Base64.decode
 instance ToJSON BS.ByteString where

server/FilterEvents.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+module FilterEvents where
+
+import Data.Maybe (mapMaybe)
+import qualified Data.Text.Lazy as LText
+import GHC.RTS.Events as GHC
+import Web.Scotty
+
+
+type EventName = LText.Text
+
+-- eventTypeNum from GHC.RTS.Events.Binary would be a nicer solution here.
+filterEvents :: [EventName] -> [Event] -> [Event]
+filterEvents en = mapMaybe (matchEvent en)
+
+matchEvent :: [EventName] -> Event -> Maybe Event
+matchEvent en e = case take 1 $ words $ show $ evSpec e of
+  [n] | LText.pack n `elem` en -> Just e
+  _                            -> Nothing
+
+-- | Return 'Just eventNames' for the filter to keep. Otherwise Nothing.
+eventFilters :: ActionM (Maybe [EventName])
+eventFilters
+  = fmap
+      (\case { [] -> Nothing ; en -> Just en }
+      . mapMaybe (\case { ("event-type", v) -> Just v ; _ -> Nothing})
+      )
+  $ params
+

server/Main.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE OverloadedStrings, LambdaCase #-}
+module Main where
 
 import Web.Scotty
 
+import Data.Maybe (mapMaybe)
 import Data.Monoid (mconcat)
 import qualified Data.Text.Lazy as LText
 import Control.Monad.IO.Class
@@ -20,6 +22,7 @@ import qualified GHC.RTS.Events as GHC
 import Network.HTTP.Types.Status (created201, internalServerError500, notFound404)
 
 import EventlogJSON
+import FilterEvents
 
 port = 3000
 
@@ -40,13 +43,18 @@ httpApp = scottyApp $ do
   get "/eventlog/:path" $ do
     eventlogPath <- BS8.unpack . Base64.decodeLenient <$> param "path"
     (mOffset, mIdx) <- range
+    mEventFilters <- eventFilters
     liftIO $ putStrLn $ "got evlog request for " ++ show (eventlogPath, mOffset, mIdx)
     liftIO (GHC.readEventLogFromFile eventlogPath) >>= \case
       Left err  -> do
         liftIO $ putStrLn "eventlog error"
         raise $ LText.pack err
       Right all@(GHC.EventLog h (GHC.Data evs)) -> do
-        let evlog = GHC.EventLog h $ GHC.Data $ maybe id take mIdx $ maybe id drop mOffset $ evs
+        let evlog = GHC.EventLog h $ GHC.Data
+                  $ maybe id filterEvents mEventFilters -- Keep the events of such kind
+                  $ maybe id take mIdx    -- Take this number of events
+                  $ maybe id drop mOffset -- Skip the beginning
+                  $ evs
         liftIO $ do
           --Aeson.encodeFile (eventlogPath ++ ".json") all
           --Aeson.encodeFile (eventlogPath ++ ".small.json") evlog
@@ -60,6 +68,7 @@ range = do
   ps <- params
   pure (read . LText.unpack <$> lookup "offset" ps, read . LText.unpack <$> lookup "idx" ps)
 
+
 notFoundA :: ActionM ()
 notFoundA = do
   status notFound404

server/code-spot-server.cabal

@@ -11,6 +11,7 @@ cabal-version:       >=1.10
 executable code-spot-server
   main-is:          Main.hs
   other-modules:    EventlogJSON
+                  , FilterEvents
 
   default-language: Haskell2010
   build-depends:    base