shrub/pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs

193 lines
5.5 KiB
Haskell
Raw Normal View History

2020-01-23 07:16:09 +03:00
{-|
Interactive Event-Log Browser
TODO Handle CTRL-D
-}
module Urbit.King.EventBrowser (run) where
import Urbit.Prelude
import Data.Conduit
import Urbit.Arvo
import Urbit.Time
import Urbit.Vere.Pier.Types
import Control.Monad.Trans.Maybe (MaybeT(..))
import Urbit.Vere.Log (EventLog)
import qualified Data.Conduit.Combinators as C
import qualified Urbit.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 <- atomically (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 mFx
Effs -> showEffects mFx >> input cyc las cur mFx
trim cyc las cur mFx = do
deleteFrom log las cur >>= \case
True -> loop cyc (pred cur) (pred cur)
False -> input cyc las cur mFx
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 "\n\n [ABORTED]\n"
putStrLn " Aborted delete, no events pruned.\n"
doDelete = do
Log.trimEvents log cur
putStrLn "\n\n [DELETED]\n"
putStrLn " It's gone forever!\n"
question =
if las == cur
then mconcat [ " This will permanently delete the last event (#"
, tshow las
, ")\n" ]
else mconcat [ " This will permanently delete all events in (#"
, tshow cur
, " - #"
, tshow las
, ")\n" ]
areYouSure = do
putStrLn "\n\n ARE YOU SURE????"
putStrLn ""
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)
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)