From ed20b7847308af70e49eb51c06d48a54f6bcddca Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 29 Aug 2019 16:48:46 -0700 Subject: [PATCH] Event/Effect browser with event trimming (not implemented yet). --- pkg/king/app/CLI.hs | 10 ++ pkg/king/app/Main.hs | 9 ++ pkg/king/lib/EventBrowser.hs | 193 +++++++++++++++++++++++++++++++++++ pkg/king/lib/Vere/Log.hs | 22 ++-- pkg/king/lib/Vere/Serf.hs | 21 ++-- 5 files changed, 232 insertions(+), 23 deletions(-) create mode 100644 pkg/king/lib/EventBrowser.hs diff --git a/pkg/king/app/CLI.hs b/pkg/king/app/CLI.hs index 4fcb18ae9b..ad1d65f63e 100644 --- a/pkg/king/app/CLI.hs +++ b/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" diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index d194d4d19f..8162cb756d 100644 --- a/pkg/king/app/Main.hs +++ b/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 diff --git a/pkg/king/lib/EventBrowser.hs b/pkg/king/lib/EventBrowser.hs new file mode 100644 index 0000000000..902d87c194 --- /dev/null +++ b/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) diff --git a/pkg/king/lib/Vere/Log.hs b/pkg/king/lib/Vere/Log.hs index 74e79a6c63..2e0a816963 100644 --- a/pkg/king/lib/Vere/Log.hs +++ b/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) diff --git a/pkg/king/lib/Vere/Serf.hs b/pkg/king/lib/Vere/Serf.hs index 3467b716be..348828ea7f 100644 --- a/pkg/king/lib/Vere/Serf.hs +++ b/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 {-