feat(sut): Make dumblog show sent messages

platonic-io · Mar 16, 2022 · 8b8f44d · 8b8f44d
1 parent 45c21d7
commit 8b8f44d
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 8 deletions.
diff --git a/src/new-debugger/src/Debugger/UI.hs b/src/new-debugger/src/Debugger/UI.hs
@@ -36,9 +36,9 @@ drawUI as = [ui]
          , vLimit 7 $ borderWithLabel (str "Reactor Log") $ renderLogs as
          ]
 
-renderEvent :: DebEvent -> String
-renderEvent (DebEvent from to event receivedLogical _) =
-  event <> ": " <> from <> " -> " <> to <> " @ " <> show receivedLogical
+renderEvent :: Bool -> DebEvent -> String
+renderEvent showMsg (DebEvent from to event receivedLogical msg) =
+  event <> ": " <> from <> " -> " <> to <> " @ " <> show receivedLogical <> if showMsg then " : " <> msg else mempty
 
 renderToString :: AppState -> (InstanceState -> String) -> Widget ()
 renderToString as f = center$ strWrapWith wrapSettings (fromMaybe "?" . fmap (f . snd) $ L.listSelectedElement $ asLog as)
@@ -60,7 +60,7 @@ renderMessage :: AppState -> Widget ()
 renderMessage as = renderToString as (message . isCurrentEvent)
 
 renderSentMessage :: AppState -> Widget ()
-renderSentMessage as = renderToString as (addEmpty . unlines . map renderEvent . isSent)
+renderSentMessage as = renderToString as (addEmpty . unlines . map (renderEvent True) . isSent)
   where
     addEmpty [] = "\n"
     addEmpty xs = xs
@@ -76,7 +76,7 @@ listDrawElement sel is =
   let selStr s = if sel
                  then withAttr customAttr (str $ ">" <> s)
                  else str $ " " <> s
-  in selStr $ renderEvent $ isCurrentEvent is
+  in selStr $ renderEvent False $ isCurrentEvent is
 
 customAttr :: AttrName
 customAttr = L.listSelectedAttr <> "custom"

diff --git a/src/sut/dumblog/src/Dumblog/Journal/Main.hs b/src/sut/dumblog/src/Dumblog/Journal/Main.hs
@@ -86,9 +86,10 @@ replayDebug originCommands originState = do
       pure dfile
     go logger logTime dfile (cmd:cmds) s = do
       putStrLn $ "[REPLAY-DEBUG] running: " <> show cmd
-      (s', _) <- runCommand (DLogger.queueLogger logger) s cmd
+      (s', r) <- runCommand (DLogger.queueLogger logger) s cmd
       logLines <- DLogger.flushQueue logger
       let
+        lbsToString = LText.unpack . LEncoding.decodeUtf8
         (ev, msg) = case cmd of
           Read i -> ("read", show i)
           Write logMsg -> ("write", Text.unpack (decodeUtf8 logMsg))
@@ -100,10 +101,17 @@ replayDebug originCommands originState = do
           , message = msg
           }
         is = InstanceStateRepr
-             { state = LText.unpack (LEncoding.decodeUtf8 (Aeson.encode (mergePatch (Aeson.toJSON s) (Aeson.toJSON s'))))
+             { state = lbsToString (Aeson.encode (mergePatch (Aeson.toJSON s) (Aeson.toJSON s')))
              , currentEvent = ce
              , logs = logLines
-             , sent = []
+             , sent = [ DebEvent
+                        { from = "dumblog"
+                        , to = "client"
+                        , event = ev
+                        , receivedLogical = logTime
+                        , message = lbsToString r
+                        }
+                      ]
              }
       go logger (succ logTime) (Vector.snoc dfile is) cmds s'