diff --git a/pkg/hs/urbit-king/TODO.md b/pkg/hs/urbit-king/TODO.md index a99928319..19f508b9d 100644 --- a/pkg/hs/urbit-king/TODO.md +++ b/pkg/hs/urbit-king/TODO.md @@ -19,7 +19,7 @@ Stubbed out: Bugs: -- [ ] In non-daemon-mode, ^D doesn't bring down Urbit properly. +- [x] In non-daemon-mode, ^D doesn't bring down Urbit properly. King-Haskell specific features: diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index 134c34fc0..2a51e1393 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -25,9 +25,6 @@ import System.Posix.Internals (c_getpid) import System.Posix.Types (CPid(..)) import System.Random (randomIO) --- Constraints ----------------------------------------------------------------- - - -- KingEnv --------------------------------------------------------------------- diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index a6a570e01..db5844d20 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -540,20 +540,25 @@ newShip CLI.New{..} opts = do runShip :: CLI.Run -> CLI.Opts -> Bool -> TMVar () -> MultiEyreApi -> RIO KingEnv () runShip (CLI.Run pierPath) opts daemon vKill multi = do - tid <- io myThreadId - let onTermExit = throwTo tid UserInterrupt - mStart <- newEmptyMVar + thisTid <- io myThreadId + mStart <- newEmptyMVar if daemon then runPier mStart else do + -- Wait until the pier has started up, then connect a terminal. If + -- the terminal ever shuts down, ask the ship to go down. connectionThread <- async $ do readMVar mStart - finally (connTerm pierPath) onTermExit - finally (runPier mStart) (cancel connectionThread) + finally (connTerm pierPath) $ do + atomically (tryPutTMVar vKill ()) + + -- Run the pier until it finishes, and then kill the terminal. + finally (runPier mStart) $ do + cancel connectionThread where - runPier mStart = - runPierEnv pierConfig networkConfig $ - tryPlayShip + runPier mStart = do + runPierEnv pierConfig networkConfig $ + tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (CLI.oDryFrom opts) @@ -736,20 +741,20 @@ runSingleShip (r, o, d) multi = do shipThread <- async (runShipNoRestart vKill r o d multi) {- - Since `spin` never returns, this will run until the main - thread is killed with an async exception. The one we expect is - `UserInterrupt` which will be raised on this thread upon SIGKILL - or SIGTERM. + Wait for the ship to go down. - Once that happens, we write to `vKill` which will cause - all ships to be shut down, and then we `wait` for them to finish - before returning. + Since `waitCatch` will never throw an exception, the `onException` + block will only happen if this thread is killed with an async + exception. The one we expect is `UserInterrupt` which will be raised + on this thread upon SIGKILL or SIGTERM. + + If this thread is killed, we first ask the ship to go down, wait + for the ship to actually go down, and then go down ourselves. -} - let spin = forever (threadDelay maxBound) - finally spin $ do + onException (void $ waitCatch shipThread) $ do logTrace "KING IS GOING DOWN" - atomically (putTMVar vKill ()) - waitCatch shipThread + void $ atomically $ tryPutTMVar vKill () + void $ waitCatch shipThread runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv () @@ -768,6 +773,10 @@ runMultipleShips ships multi = do Once that happens, we write to `vKill` which will cause all ships to be shut down, and then we `wait` for them to finish before returning. + + This is different than the single-ship flow, because ships never + go down on their own in this flow. If they go down, they just bring + themselves back up. -} let spin = forever (threadDelay maxBound) finally spin $ do diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index c5b9398ad..a6cd0482c 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -327,9 +327,11 @@ pier (serf, log) vSlog mStart vKilled multi = do -- bullshit scry tester void $ acquireWorker "bullshit scry tester" $ forever $ do + env <- ask threadDelay 1_000_000 wen <- io Time.now - let kal = \mTermNoun -> print ("scry result: ", mTermNoun) + let kal = \mTermNoun -> runRIO env $ do + logTrace $ displayShow ("scry result: ", mTermNoun) let nkt = MkKnot $ tshow $ Time.MkDate wen let pax = Path ["j", "~zod", "life", nkt, "~zod"] atomically $ putTMVar scryM (wen, Nothing, pax, kal) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs index f205eeb7b..403226657 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs @@ -110,7 +110,10 @@ execReplay serf log last = do logTrace $ display $ "Replaying up to event #" <> tshow replayUpTo logTrace $ display $ "Will replay " <> tshow numEvs <> " in total." - let onProgress n = print ("Serf is at event# " <> tshow n) + env <- ask + + let onProgress n = do + runRIO env $ logTrace $ display ("Serf is at event# " <> tshow n) runResourceT $ runConduit diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs index fe7914c48..5a5257103 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs @@ -608,7 +608,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop que <- newTBMQueueIO 1 () <- atomically (writeTBMQueue que firstWorkErr) tWork <- async (processWork serf maxBatchSize que onWorkResp spin) - flip onException (print "KILLING: run" >> cancel tWork) $ do + flip onException (cancel tWork) $ do nexSt <- workLoop que wait tWork nexSt