Event/Effect browser with event trimming (not implemented yet).

pkg/king/app/CLI.hs

@@ -49,6 +49,9 @@ data Bug
     | CollectAllFX
         { bPierPath :: FilePath
         }
+    | EventBrowser
+        { bPierPath :: FilePath
+        }
     | ValidateEvents
         { bPierPath :: FilePath
         , bFirstEvt :: Word64
@@ -240,6 +243,9 @@ checkEvs = ValidateEvents <$> pierPath <*> firstEv <*> lastEv
 checkFx :: Parser Bug
 checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
 
+browseEvs :: Parser Bug
+browseEvs = EventBrowser <$> pierPath
+
 bugCmd :: Parser Cmd
 bugCmd = fmap CmdBug
         $ subparser
@@ -255,6 +261,10 @@ bugCmd = fmap CmdBug
             ( info (checkEvs <**> helper)
             $ progDesc "Parse all data in event log"
             )
+       <> command "event-browser"
+            ( info (browseEvs <**> helper)
+            $ progDesc "Interactively view (and prune) event log"
+            )
        <> command "validate-effects"
             ( info (checkFx <**> helper)
             $ progDesc "Parse all data in event log"

pkg/king/app/Main.hs

@@ -109,6 +109,7 @@ import qualified Data.Set  as Set
 import qualified Vere.Log  as Log
 import qualified Vere.Pier as Pier
 import qualified Vere.Serf as Serf
+import qualified EventBrowser
 
 --------------------------------------------------------------------------------
 
@@ -357,11 +358,19 @@ newShip CLI.New{..} _ = do
 runShip :: HasLogFunc e => CLI.Run -> CLI.Opts -> RIO e ()
 runShip (CLI.Run pierPath) _ = tryPlayShip pierPath
 
+startBrowser :: HasLogFunc e => FilePath -> RIO e ()
+startBrowser pierPath =
+    rwith (Log.existing logPath) $ \log ->
+        EventBrowser.run log
+  where
+    logPath = pierPath <> "/.urb/log"
+
 main :: IO ()
 main = CLI.parseArgs >>= runApp . \case
     CLI.CmdRun r o                             -> runShip r o
     CLI.CmdNew n o                             -> newShip n o
     CLI.CmdBug (CLI.CollectAllFX pax)          -> collectAllFx pax
+    CLI.CmdBug (CLI.EventBrowser pax)          -> startBrowser pax
     CLI.CmdBug (CLI.ValidatePill pax pil seq)  -> testPill pax pil seq
     CLI.CmdBug (CLI.ValidateEvents pax f l)    -> checkEvs pax f l
     CLI.CmdBug (CLI.ValidateFX pax f l)        -> checkFx  pax f l

pkg/king/lib/EventBrowser.hs

@@ -0,0 +1,193 @@
+{-
+    TODO Handle CTRL-D
+-}
+
+module EventBrowser (run) where
+
+import UrbitPrelude
+
+import Arvo
+import Data.Conduit
+import Urbit.Time
+import Vere.Pier.Types
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+import Vere.Log  (EventLog)
+
+import qualified Data.Conduit.Combinators as C
+import qualified Vere.Log                 as Log
+
+--------------------------------------------------------------------------------
+
+data Event = Event
+    { num :: Word64
+    , mug :: Mug
+    , wen :: Wen
+    , ova :: Ev
+    }
+  deriving Show
+
+data Input
+    = Next
+    | Prev
+    | Quit
+    | Trim
+    | Effs
+    | Init
+    | Last
+
+--------------------------------------------------------------------------------
+
+run :: HasLogFunc e => EventLog -> RIO e ()
+run log = do
+    hSetBuffering stdin NoBuffering
+    hSetEcho stdin False
+    logInfo $ displayShow (Log.identity log)
+    let cycle = fromIntegral $ lifecycleLen $ Log.identity log
+    las <- Log.lastEv log
+    loop cycle las las
+  where
+    failRead cur =
+        putStrLn ("ERROR: Failed to read event: " <> tshow cur)
+
+    input cyc las cur mFx = do
+        getInput las cur >>= \case
+            Next -> loop cyc las (succ cur)
+            Prev -> loop cyc las (pred cur)
+            Init -> loop cyc las 1
+            Last -> loop cyc las las
+            Quit -> pure ()
+            Trim -> trim cyc las cur
+            Effs -> showEffects mFx >> input cyc las cur mFx
+
+    trim cyc las cur = do
+        deleteFrom log las cur >>= \case
+            True  -> loop cyc (pred cur) (pred cur)
+            False -> loop cyc las cur
+
+    loop cyc las 0                = loop cyc las 1
+    loop cyc las cur | cur > las  = loop cyc las las
+    loop cyc las cur | cyc >= cur = do
+        putStrLn ""
+        putStrLn "    [EVENT]"
+        putStrLn ""
+        putStrLn "    Lifecycle Nock"
+        putStrLn ""
+        input cyc las cur (Just [])
+
+    loop cyc las cur = do
+        mEv <- peekEvent  log cur
+        mFx <- peekEffect log cur
+
+        case mEv of
+            Nothing -> failRead cur
+            Just ev -> showEvent ev >> showEffectsTeaser mFx
+
+        input cyc las cur mFx
+
+deleteFrom :: HasLogFunc e => EventLog -> Word64 -> Word64 -> RIO e Bool
+deleteFrom log las cur = do
+    sure <- areYouSure
+    if sure then doDelete else abortDelete
+    pure sure
+  where
+    abortDelete = do
+        putStrLn "Aborted delete -- no events pruned"
+
+    doDelete = Log.trimEvents log cur
+
+    question =
+      if las == cur
+      then mconcat [ "Are you sure you want to the last event (#"
+                   , tshow las
+                   , ")?" ]
+      else mconcat [ "Are you sure you want to all events (#"
+                   , tshow cur
+                   , " - #"
+                   , tshow las
+                   , ")?" ]
+
+    areYouSure = do
+        putStrLn question
+        putStr "(y|n) "
+        hFlush stdout
+        getChar <&> \case
+          'y' -> True
+          _   -> False
+
+getInput :: Word64 -> Word64 -> RIO e Input
+getInput las cur = do
+    putStr ("(" <> tshow cur <> "/" <> tshow las <> ") ")
+    hFlush stdout
+    getChar >>= \case
+        'j'    -> pure Next
+        'k'    -> pure Prev
+        'q'    -> pure Quit
+        'f'    -> pure Effs
+        'x'    -> pure Trim
+        '0'    -> pure Init
+        'G'    -> pure Last
+        _      -> do putStrLn "\n"
+                     putStrLn help
+                     getInput las cur
+  where
+    help = unlines
+       [ "    [HELP]"
+       , ""
+       , "    k    View the previous event"
+       , "    j    View the next event"
+       , "    0    View the first event"
+       , "    G    View the last event"
+       , "    q    Quit"
+       , "    x    Delete (only the last event)"
+       , "    ?    Show this help"
+       , ""
+       ]
+
+showEffectsTeaser :: Maybe FX -> RIO e ()
+showEffectsTeaser Nothing   = putStrLn "No collected effects\n"
+showEffectsTeaser (Just []) = putStrLn "No effects for this event\n"
+showEffectsTeaser (Just fx) = putStrLn $ mconcat
+    [ tshow (length fx)
+    , " collected effects. Press 'f' to view.\n"
+    ]
+
+showEffects :: Maybe FX -> RIO e ()
+showEffects Nothing   = putStrLn "No collected effects\n"
+showEffects (Just []) = putStrLn "No effects for this event\n"
+showEffects (Just fx) = do
+    putStrLn "\n"
+    putStrLn "    [EFFECTS]"
+    for_ fx $ \ef -> do
+        putStrLn ""
+        showEffect ef
+    putStrLn ""
+
+showEffect :: Lenient Ef -> RIO e ()
+showEffect (GoodParse ef) =
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow ef
+showEffect (FailParse n) =
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow n
+
+showEvent :: Event -> RIO e ()
+showEvent ev = do
+    putStrLn "\n"
+    putStrLn "    [EVENT]"
+    putStrLn ""
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow (ova ev)
+    putStrLn ""
+
+peekEffect :: HasLogFunc e => EventLog -> Word64 -> RIO e (Maybe FX)
+peekEffect log eId = runMaybeT $ do
+   (id, bs) <- MaybeT $ runConduit (Log.streamEffectsRows log eId .| C.head)
+   guard (id == eId)
+   io $ cueBSExn bs >>= fromNounExn
+
+peekEvent :: HasLogFunc e => EventLog -> Word64 -> RIO e (Maybe Event)
+peekEvent log eId = runMaybeT $ do
+    octs    <- MaybeT $ runConduit (Log.streamEvents log eId .| C.head)
+    noun    <- io $ cueBSExn octs
+    (m,w,e) <- io $ fromNounExn noun
+    ovum    <- fromNounExn e
+    pure (Event eId m w ovum)

pkg/king/lib/Vere/Log.hs

@@ -2,9 +2,9 @@
     TODO Effects storage logic is messy.
 -}
 
-module Vere.Log ( EventLog, identity, nextEv
+module Vere.Log ( EventLog, identity, nextEv, lastEv
                 , new, existing
-                , streamEvents, appendEvents
+                , streamEvents, appendEvents, trimEvents
                 , streamEffectsRows, writeEffectsRow
                 ) where
 
@@ -251,6 +251,13 @@ writeEffectsRow log k v = do
 --------------------------------------------------------------------------------
 -- Read Events -----------------------------------------------------------------
 
+trimEvents :: HasLogFunc e => EventLog -> Word64 -> RIO e ()
+trimEvents log start = do
+    rwith (writeTxn $ env log) $ \txn -> do
+        logError "(trimEvents): Not implemented."
+        pure ()
+    writeIORef (numEvents log) (pred start)
+
 streamEvents :: HasLogFunc e
              => EventLog -> Word64
              -> ConduitT () ByteString (RIO e) ()
@@ -318,22 +325,21 @@ readRowsBatch :: ∀e. HasLogFunc e
 readRowsBatch env dbi first = readRows
   where
     readRows = do
-        logDebug $ displayShow ("readRows", first)
+        logDebug $ display ("(readRowsBatch) From: " <> tshow first)
         withWordPtr first $ \pIdx ->
             withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
             rwith (readTxn env) $ \txn ->
             rwith (cursor txn dbi) $ \cur ->
             io (mdb_cursor_get MDB_SET_RANGE cur pKey pVal) >>= \case
                 False -> pure mempty
-                True  -> V.unfoldrM (fetchRows cur pKey pVal) 1000
+                True  -> V.unfoldrM (fetchBatch cur pKey pVal) 1000
 
-    fetchRows :: Cur -> Ptr Val -> Ptr Val -> Word
+    fetchBatch :: Cur -> Ptr Val -> Ptr Val -> Word
               -> RIO e (Maybe ((Word64, ByteString), Word))
-    fetchRows cur pKey pVal 0 = pure Nothing
-    fetchRows cur pKey pVal n = do
+    fetchBatch cur pKey pVal 0 = pure Nothing
+    fetchBatch cur pKey pVal n = do
         key <- io $ peek pKey >>= mdbValToWord64
         val <- io $ peek pVal >>= mdbValToBytes
-        logDebug $ displayShow ("fetchRows", n, key, val)
         io $ mdb_cursor_get MDB_NEXT cur pKey pVal >>= \case
             False -> pure $ Just ((key, val), 0)
             True  -> pure $ Just ((key, val), pred n)

pkg/king/lib/Vere/Serf.hs

@@ -228,18 +228,9 @@ sendLen s i = do
 
 sendOrder :: HasLogFunc e => Serf -> Order -> RIO e ()
 sendOrder w o = do
-  logDebug $ display ("[Serf.sendOrder.toNoun] " <> tshow o)
-  n <- evaluate (toNoun o)
-
-  case o of
-    OWork (DoWork (Work _ _ _ e)) -> do logTrace $ displayShow $ toNoun (e::Ev)
-    _                             -> do pure ()
-
-  logDebug "[Serf.sendOrder.jam]"
-  bs <- evaluate (jamBS n)
-  logDebug $ display ("[Serf.sendOrder.send]: " <> tshow (length bs))
-  sendBytes w bs
-  logDebug "[Serf.sendOrder.sent]"
+  logDebug $ display ("(sendOrder) " <> tshow o)
+  sendBytes w $ jamBS $ toNoun o
+  logDebug "(sendOrder) Done"
 
 sendBytes :: Serf -> ByteString -> RIO e ()
 sendBytes s bs = handle ioErr $ do
@@ -297,9 +288,9 @@ shutdown serf code = sendOrder serf (OExit code)
 -}
 recvPlea :: HasLogFunc e => Serf -> RIO e Plea
 recvPlea w = do
-  logDebug "[Vere.Serf.recvPlea] waiting"
+  logDebug "(recvPlea) Waiting"
   a <- recvAtom w
-  logDebug "[Vere.Serf.recvPlea] got atom"
+  logDebug "(recvPlea) Got atom"
   n <- fromRightExn (cue a) (const $ BadPleaAtom a)
   p <- fromRightExn (fromNounErr n) (\(p,m) -> BadPleaNoun (traceShowId n) p m)
 
@@ -307,7 +298,7 @@ recvPlea w = do
                                 recvPlea w
             PSlog _ pri t -> do printTank pri t
                                 recvPlea w
-            _             -> do logTrace $ display ("recvPlea got: " <> tshow p)
+            _             -> do logTrace $ display ("(recvPlea) " <> tshow p)
                                 pure p
 
 {-