king: Shutdown TMVars now live in KingEnv/PierEnv.

2025-01-01 17:16:47 +03:00 · 2020-06-06 23:03:20 +00:00 · 2020-06-06 23:03:20 +00:00 · 648b0743c8
commit 648b0743c8
parent bd51337156
5 changed files with 108 additions and 75 deletions
--- a/pkg/hs/urbit-king/TODO.md
+++ b/pkg/hs/urbit-king/TODO.md
@ -52,8 +52,8 @@ Polish:

 # Cleanup

- [ ] ShutdownSTM action that's passed to the terminal driver should
-      live in `PierEnv` and should be available to all drivers.
+- [x] ShutdownSTM action that's passed to the terminal driver should
+      live in `KingEnv` and should be available to all drivers.
 - [ ] Break most logic from `Main.hs` out into modules.
 - [ ] Simplify `Main.hs` flows.
 - [ ] Cleanup Terminal Driver code.
--- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs
@ -6,8 +6,13 @@ module Urbit.King.App
  , runKingEnvStderr
  , runKingEnvLogFile
  , runKingEnvNoLog
+  , kingEnvKillSignal
+  , killKingActionL
+  , onKillKingSigL
  , PierEnv
  , runPierEnv
+  , killPierActionL
+  , onKillPierSigL
  , HasStderrLogFunc(..)
  , HasKingId(..)
  , HasProcId(..)
@ -47,6 +52,7 @@ data KingEnv = KingEnv
  , _kingEnvStderrLogFunc :: !LogFunc
  , _kingEnvKingId        :: !Word16
  , _kingEnvProcId        :: !Int32
+  , _kingEnvKillSignal    :: !(TMVar ())
  }

 makeLenses ''KingEnv
@ -104,7 +110,18 @@ runKingEnv :: LogFunc -> LogFunc -> RIO KingEnv a -> IO a
 runKingEnv logFunc stderr action = do
  kid      <- randomIO
  CPid pid <- c_getpid
-  runRIO (KingEnv logFunc stderr kid pid) action
+  kil      <- newEmptyTMVarIO
+  runRIO (KingEnv logFunc stderr kid pid kil) action
+
+
+-- KingEnv Utils ---------------------------------------------------------------
+
+onKillKingSigL :: HasKingEnv e => Getter e (STM ())
+onKillKingSigL = kingEnvL . kingEnvKillSignal . to readTMVar
+
+killKingActionL :: HasKingEnv e => Getter e (STM ())
+killKingActionL =
+  kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))


 -- PierEnv ---------------------------------------------------------------------
@ -116,6 +133,7 @@ data PierEnv = PierEnv
  { _pierEnvKingEnv       :: !KingEnv
  , _pierEnvPierConfig    :: !PierConfig
  , _pierEnvNetworkConfig :: !NetworkConfig
+  , _pierEnvKillSignal    :: !(TMVar ())
  }

 makeLenses ''PierEnv
@ -151,15 +169,27 @@ instance HasProcId PierEnv where
  procIdL = kingEnvL . kingEnvProcId


+-- PierEnv Utils ---------------------------------------------------------------
+
+onKillPierSigL :: HasPierEnv e => Getter e (STM ())
+onKillPierSigL = pierEnvL . pierEnvKillSignal . to readTMVar
+
+killPierActionL :: HasPierEnv e => Getter e (STM ())
+killPierActionL =
+  pierEnvL . pierEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
+
+
 -- Running Pier Envs -----------------------------------------------------------

-runPierEnv :: PierConfig -> NetworkConfig -> RIO PierEnv a -> RIO KingEnv a
-runPierEnv pierConfig networkConfig action = do
+runPierEnv
+  :: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
+runPierEnv pierConfig networkConfig vKill action = do
  app <- ask

  let pierEnv = PierEnv { _pierEnvKingEnv       = app
                        , _pierEnvPierConfig    = pierConfig
                        , _pierEnvNetworkConfig = networkConfig
+                        , _pierEnvKillSignal    = vKill
                        }

  io (runRIO pierEnv action)
--- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
@ -91,7 +91,9 @@ import Control.Exception      (AsyncException(UserInterrupt))
 import Control.Lens           ((&))
 import System.Process         (system)
 import Text.Show.Pretty       (pPrint)
-import Urbit.King.App         (KingEnv, PierEnv)
+import Urbit.King.App         (KingEnv, PierEnv, kingEnvKillSignal)
+import Urbit.King.App         (killKingActionL, onKillKingSigL)
+import Urbit.King.App         (killPierActionL)
 import Urbit.King.App         (runKingEnvLogFile, runKingEnvStderr, runPierEnv)
 import Urbit.Noun.Conversions (cordToUW)
 import Urbit.Time             (Wen)
@ -178,27 +180,25 @@ tryBootFromPill
  -> MultiEyreApi
  -> RIO PierEnv ()
 tryBootFromPill oExit pill lite flags ship boot multi = do
-    mStart <- newEmptyMVar
-    vKill  <- newEmptyTMVarIO
-    vSlog  <- logSlogs
-    runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart vKill multi
-  where
-    bootedPier vSlog = do
-        view pierPathL >>= lockFile
-        rio $ logTrace "Starting boot"
-        sls <- Pier.booted vSlog pill lite flags ship boot
-        rio $ logTrace "Completed boot"
-        pure sls
+  mStart <- newEmptyMVar
+  vSlog  <- logSlogs
+  runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
+ where
+  bootedPier vSlog = do
+    view pierPathL >>= lockFile
+    rio $ logTrace "Starting boot"
+    sls <- Pier.booted vSlog pill lite flags ship boot
+    rio $ logTrace "Completed boot"
+    pure sls

 runOrExitImmediately
  :: TVar (Text -> IO ())
  -> RAcquire PierEnv (Serf, Log.EventLog)
  -> Bool
  -> MVar ()
-  -> TMVar ()
  -> MultiEyreApi
  -> RIO PierEnv ()
-runOrExitImmediately vSlog getPier oExit mStart vKill multi = do
+runOrExitImmediately vSlog getPier oExit mStart multi = do
  rwith getPier (if oExit then shutdownImmediately else runPier)
 where
  shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
@ -209,7 +209,7 @@ runOrExitImmediately vSlog getPier oExit mStart vKill multi = do

  runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
  runPier serfLog = do
-    runRAcquire (Pier.pier serfLog vSlog mStart vKill multi)
+    runRAcquire (Pier.pier serfLog vSlog mStart multi)

 tryPlayShip
  :: Bool
@ -217,13 +217,12 @@ tryPlayShip
  -> Maybe Word64
  -> [Serf.Flag]
  -> MVar ()
-  -> TMVar ()
  -> MultiEyreApi
  -> RIO PierEnv ()
-tryPlayShip exitImmediately fullReplay playFrom flags mStart vKill multi = do
+tryPlayShip exitImmediately fullReplay playFrom flags mStart multi = do
  when fullReplay wipeSnapshot
  vSlog <- logSlogs
-  runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart vKill multi
+  runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
 where
  wipeSnapshot = do
    shipPath <- view pierPathL
@ -532,15 +531,23 @@ newShip CLI.New{..} opts = do
    -- Now that we have all the information for running an application with a
    -- PierConfig, do so.
    runTryBootFromPill multi pill name ship bootEvent = do
+      vKill <- view kingEnvKillSignal
      let pierConfig = toPierConfig (pierPath name) opts
      let networkConfig = toNetworkConfig opts
-      runPierEnv pierConfig networkConfig $
+      runPierEnv pierConfig networkConfig vKill $
        tryBootFromPill True pill nLite flags ship bootEvent multi
 ------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent

-runShip :: CLI.Run -> CLI.Opts -> Bool -> TMVar () -> MultiEyreApi -> RIO KingEnv ()
-runShip (CLI.Run pierPath) opts daemon vKill multi = do
-    thisTid <- io myThreadId
+runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
+runShipEnv (CLI.Run pierPath) opts vKill act = do
+  runPierEnv pierConfig netConfig vKill act
+ where
+  pierConfig = toPierConfig pierPath opts
+  netConfig = toNetworkConfig opts
+
+runShip
+  :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv ()
+runShip (CLI.Run pierPath) opts daemon multi = do
    mStart  <- newEmptyMVar
    if daemon
    then runPier mStart
@ -550,24 +557,20 @@ runShip (CLI.Run pierPath) opts daemon vKill multi = do
      connectionThread <- async $ do
        readMVar mStart
        finally (connTerm pierPath) $ do
-          atomically (tryPutTMVar vKill ())
+          view killPierActionL >>= atomically

      -- Run the pier until it finishes, and then kill the terminal.
      finally (runPier mStart) $ do
        cancel connectionThread
  where
    runPier mStart = do
-      runPierEnv pierConfig networkConfig $
-        tryPlayShip
-              (CLI.oExit opts)
-              (CLI.oFullReplay opts)
-              (CLI.oDryFrom opts)
-              (toSerfFlags opts)
-              mStart
-              vKill
-              multi
-    pierConfig = toPierConfig pierPath opts
-    networkConfig = toNetworkConfig opts
+      tryPlayShip
+        (CLI.oExit opts)
+        (CLI.oFullReplay opts)
+        (CLI.oDryFrom opts)
+        (toSerfFlags opts)
+        mStart
+        multi


 startBrowser :: HasLogFunc e => FilePath -> RIO e ()
@ -652,15 +655,18 @@ main = do
  TODO Use logging system instead of printing.
 -}
 runShipRestarting
-  :: TMVar () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
-runShipRestarting vKill r o multi = do
+  :: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
+runShipRestarting r o multi = do
  let pier = pack (CLI.rPierPath r)
-      loop = runShipRestarting vKill r o multi
+      loop = runShipRestarting r o multi

-  tid <- asyncBound (runShip r o True vKill multi)
+  onKill    <- view onKillKingSigL
+  vKillPier <- newEmptyTMVarIO
+
+  tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi

  let onShipExit = Left <$> waitCatchSTM tid
-      onKillRequ = Right <$> readTMVar vKill
+      onKillRequ = Right <$> onKill

  atomically (onShipExit <|> onKillRequ) >>= \case
    Left exit -> do
@ -681,14 +687,17 @@ runShipRestarting vKill r o multi = do
 {-
  TODO This is messy and shared a lot of logic with `runShipRestarting`.
 -}
-runShipNoRestart :: TMVar () -> CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv ()
-runShipNoRestart vKill r o d multi = do
-  tid <- asyncBound (runShip r o d vKill multi)
+runShipNoRestart
+  :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv ()
+runShipNoRestart r o d multi = do
+  vKill  <- view kingEnvKillSignal -- killing ship same as killing king
+  tid    <- asyncBound (runShipEnv r o vKill $ runShip r o d multi)
+  onKill <- view onKillKingSigL

  let pier = pack (CLI.rPierPath r)

  let onShipExit = Left <$> waitCatchSTM tid
-      onKillRequ = Right <$> readTMVar vKill
+      onKillRequ = Right <$> onKill

  atomically (onShipExit <|> onKillRequ) >>= \case
    Left (Left err) -> do
@ -736,9 +745,7 @@ runShips CLI.KingOpts {..} ships = do
 -- TODO Duplicated logic.
 runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> MultiEyreApi -> RIO KingEnv ()
 runSingleShip (r, o, d) multi = do
-  vKill <- newEmptyTMVarIO
-
-  shipThread <- async (runShipNoRestart vKill r o d multi)
+  shipThread <- async (runShipNoRestart r o d multi)

  {-
    Wait for the ship to go down.
@ -753,16 +760,15 @@ runSingleShip (r, o, d) multi = do
  -}
  onException (void $ waitCatch shipThread) $ do
    logTrace "KING IS GOING DOWN"
-    void $ atomically $ tryPutTMVar vKill ()
-    void $ waitCatch shipThread
+    atomically =<< view killKingActionL
+    waitCatch shipThread
+    pure ()


 runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv ()
 runMultipleShips ships multi = do
-  vKill <- newEmptyTMVarIO
-
  shipThreads <- for ships $ \(r, o) -> do
-    async (runShipRestarting vKill r o multi)
+    async (runShipRestarting r o multi)

  {-
    Since `spin` never returns, this will run until the main
@ -770,9 +776,9 @@ runMultipleShips ships multi = do
    `UserInterrupt` which will be raised on this thread upon SIGKILL
    or SIGTERM.

-    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.
+    Once that happens, we send a shutdown signal 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
@ -781,7 +787,7 @@ runMultipleShips ships multi = do
  let spin = forever (threadDelay maxBound)
  finally spin $ do
    logTrace "KING IS GOING DOWN"
-    atomically (putTMVar vKill ())
+    view killKingActionL >>= atomically
    for_ shipThreads waitCatch


@ -790,6 +796,7 @@ runMultipleShips ships multi = do
 connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
 connTerm = Term.runTerminalClient

+
 --------------------------------------------------------------------------------

 checkFx :: HasLogFunc e
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
@ -27,6 +27,7 @@ import Urbit.Vere.Pier.Types
 import Data.Text              (append)
 import System.Posix.Files     (ownerModes, setFileMode)
 import Urbit.King.App         (HasKingEnv, HasPierEnv(..), PierEnv)
+import Urbit.King.App         (onKillPierSigL)
 import Urbit.Time             (Wen)
 import Urbit.Vere.Ames        (ames)
 import Urbit.Vere.Behn        (behn)
@ -239,10 +240,9 @@ pier
  :: (Serf, EventLog)
  -> TVar (Text -> IO ())
  -> MVar ()
-  -> TMVar ()
  -> MultiEyreApi
  -> RAcquire PierEnv ()
-pier (serf, log) vSlog mStart vKilled multi = do
+pier (serf, log) vSlog mStart multi = do
    computeQ  <- newTQueueIO @_ @Serf.EvErr
    persistQ  <- newTQueueIO
    executeQ  <- newTQueueIO
@ -255,8 +255,6 @@ pier (serf, log) vSlog mStart vKilled multi = do
        writeTVar (King.kTermConn kapi) (Just $ writeTQueue q)
        pure q

-    let shutdownEvent = void (tryPutTMVar vKilled ())
-
    -- (sz, local) <- Term.localClient

    -- (waitExternalTerm, termServPort) <- Term.termServer
@ -297,7 +295,6 @@ pier (serf, log) vSlog mStart vKilled multi = do
    let (bootEvents, startDrivers) =
            drivers env multi ship (isFake logId)
                (writeTQueue computeQ)
-                shutdownEvent
                (Term.TSize{tsWide=80, tsTall=24}, muxed)
                showErr

@ -305,9 +302,11 @@ pier (serf, log) vSlog mStart vKilled multi = do

    scryM <- newEmptyTMVarIO

+    onKill <- view onKillPierSigL
+
    let computeConfig = ComputeConfig
          { ccOnWork = readTQueue computeQ
-          , ccOnKill = readTMVar vKilled
+          , ccOnKill = onKill
          , ccOnSave = takeTMVar saveM
          , ccOnScry = takeTMVar scryM
          , ccPutResult = writeTQueue persistQ
@ -385,11 +384,10 @@ drivers
  -> Ship
  -> Bool
  -> (EvErr -> STM ())
-  -> STM ()
  -> (Term.TSize, Term.Client)
  -> (Text -> RIO e ())
  -> ([EvErr], RAcquire e (Drivers e))
-drivers env multi who isFake plan shutdownSTM termSys stderr =
+drivers env multi who isFake plan termSys stderr =
    (initialEvents, runDrivers) -- TODO
  where
    (behnBorn, runBehn) = behn env plan
@ -397,7 +395,7 @@ drivers env multi who isFake plan shutdownSTM termSys stderr =
    (httpBorn, runHttp) = eyre env multi who plan isFake
    (clayBorn, runClay) = clay env plan
    (irisBorn, runIris) = client env plan
-    (termBorn, runTerm) = Term.term env termSys shutdownSTM plan
+    (termBorn, runTerm) = Term.term env termSys plan
    initialEvents       = mconcat [behnBorn, clayBorn, amesBorn, httpBorn,
                                   termBorn, irisBorn]
    runDrivers          = do
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
@ -18,7 +18,6 @@ import RIO.FilePath
 import System.Posix.IO
 import System.Posix.Terminal
 import Urbit.Arvo            hiding (Term)
-import Urbit.King.Config
 import Urbit.Prelude         hiding (getCurrentTime)
 import Urbit.Time
 import Urbit.Vere.Pier.Types
@ -26,7 +25,7 @@ import Urbit.Vere.Pier.Types
 import Data.List           ((!!))
 import RIO.Directory       (createDirectoryIfMissing)
 import Urbit.King.API      (readPortsFile)
-import Urbit.King.App      (HasKingId(..), HasPierPath(..))
+import Urbit.King.App      (HasPierPath(..), HasPierEnv, killPierActionL)
 import Urbit.Vere.Term.API (Client(Client))

 import qualified Data.ByteString.Internal as BS
@ -502,13 +501,12 @@ initialHailFailed env _ = runRIO env $ do
 {-|
    Terminal Driver
 -}
-term :: forall e. (HasPierConfig e, HasLogFunc e, HasKingId e)
+term :: forall e. (HasPierEnv e)
     => e
     -> (T.TSize, Client)
-     -> (STM ())
     -> (EvErr -> STM ())
     -> ([EvErr], RAcquire e (EffCb e TermEf))
-term env (tsize, Client{..}) shutdownSTM plan =
+term env (tsize, Client{..}) plan =
    (initialEvents, runTerm)
  where
    T.TSize wi hi = tsize
@ -540,7 +538,7 @@ term env (tsize, Client{..}) shutdownSTM plan =
    handleEffect = \case
        TermEfInit _ _     -> pure ()
        TermEfMass _ _     -> pure ()
-        TermEfLogo _ _     -> atomically shutdownSTM
+        TermEfLogo _ _     -> atomically =<< view killPierActionL
        TermEfBlit _ blits -> do
            let (termBlits, fsWrites) = partition isTerminalBlit blits
            atomically $ give [Term.Blits termBlits]