king: Snapshot on shutdown; no snapshot on start if no events to replay.

pkg/hs/urbit-king/TODO.md

@@ -39,9 +39,9 @@ Polish:
 - [x] King should shutdown promptly on ^C. Always takes 2s in practice.
 - [x] Bring back progress bars.
 - [x] Make sure replay progress bars go to stderr.
-- [ ] Logging for new IPC flow.
-- [ ] Logging for boot sequence.
-- [ ] Take snapshots on clean shutdown.
+- [x] Logging for new IPC flow.
+- [x] Logging for boot sequence.
+- [x] Take snapshots on clean shutdown.
 
 # Misc Bugs
 

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

@@ -356,9 +356,9 @@ replayPartEvs top last = do
         rio $ do
           eSs <- Serf.execReplay serf log (Just last)
           case eSs of
-            Just bail -> error (show bail)
-            Nothing   -> pure ()
-          io (Serf.snapshot serf)
+            Left bail -> error (show bail)
+            Right 0   -> io (Serf.snapshot serf)
+            Right num -> pure ()
           io $ threadDelay 500000 -- Copied from runOrExitImmediately
           pure ()
 

pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs

@@ -206,10 +206,14 @@ resumed vSlog replayUntil flags  = do
 
   rio $ do
     logTrace "Replaying events"
-    Serf.execReplay serf log replayUntil
-    logTrace "Taking snapshot"
-    io (Serf.snapshot serf)
-    logTrace "Shuting down the serf"
+    Serf.execReplay serf log replayUntil >>= \case
+      Left err -> error (show err)
+      Right 0  -> do
+        logTrace "No work during replay so no snapshot"
+        pure ()
+      Right _  -> do
+        logTrace "Taking snapshot"
+        io (Serf.snapshot serf)
 
   pure (serf, log)
 

pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs

@@ -51,12 +51,12 @@ execReplay
   => Serf
   -> Log.EventLog
   -> Maybe Word64
-  -> RIO e (Maybe PlayBail)
+  -> RIO e (Either PlayBail Word)
 execReplay serf log last = do
   lastEventInSnap <- io (serfLastEventBlocking serf)
   if lastEventInSnap == 0 then doBoot else doReplay
  where
-  doBoot :: RIO e (Maybe PlayBail)
+  doBoot :: RIO e (Either PlayBail Word)
   doBoot = do
     logTrace "Beginning boot sequence"
 
@@ -76,13 +76,15 @@ execReplay serf log last = do
 
     io (boot serf evs) >>= \case
       Just err -> do
-        logTrace "Finished boot events, nothing more to replay."
-        pure (Just err)
+        logTrace "Error on replay, exiting"
+        pure (Left err)
       Nothing  -> do
         logTrace "Finished boot events, moving on to more events from log."
-        doReplay
+        doReplay <&> \case
+          Left err  -> Left err
+          Right num -> Right (num + numEvs)
 
-  doReplay :: RIO e (Maybe PlayBail)
+  doReplay :: RIO e (Either PlayBail Word)
   doReplay = do
     logTrace "Beginning event log replay"
 
@@ -118,7 +120,9 @@ execReplay serf log last = do
       .| CC.mapM (fmap snd . parseLogRow)
       .| replay 5 incProgress serf
 
-    pure res
+    res & \case
+      Nothing -> pure (Right $ fromIntegral numEvs)
+      Just er -> pure (Left er)
 
 logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
 logStderr action = do

pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs

@@ -512,7 +512,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
   topLoop = atomically onInput >>= \case
     RRWork workErr -> doWork workErr
     RRSave ()      -> doSave
-    RRKill ()      -> pure ()
+    RRKill ()      -> doKill
     RRPack ()      -> doPack
     RRScry w g p k -> doScry w g p k
 
@@ -529,6 +529,9 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
   doSave :: IO ()
   doSave = waitForLog >> snapshot serf >> topLoop
 
+  doKill :: IO ()
+  doKill = waitForLog >> snapshot serf >> pure ()
+
   doScry :: Wen -> Gang -> Path -> (Maybe (Term, Noun) -> IO ()) -> IO ()
   doScry w g p k = (scry serf w g p >>= k) >> topLoop
 
@@ -544,7 +547,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
 
   workLoop :: TBMQueue EvErr -> IO (IO ())
   workLoop que = atomically onInput >>= \case
-    RRKill ()      -> atomically (closeTBMQueue que) >> pure (pure ())
+    RRKill ()      -> atomically (closeTBMQueue que) >> pure doKill
     RRSave ()      -> atomically (closeTBMQueue que) >> pure doSave
     RRPack ()      -> atomically (closeTBMQueue que) >> pure doPack
     RRScry w g p k -> atomically (closeTBMQueue que) >> pure (doScry w g p k)