diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index 225e7f4b45..b10ba12e3f 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -9,8 +9,8 @@ module Urbit.King.App , kingEnvKillSignal , killKingActionL , onKillKingSigL - , RunningEnv - , runRunningEnv + , HostEnv + , runHostEnv , PierEnv , runPierEnv , killPierActionL @@ -20,7 +20,7 @@ module Urbit.King.App , HasProcId(..) , HasKingEnv(..) , HasMultiEyreApi(..) - , HasRunningEnv(..) + , HasHostEnv(..) , HasPierEnv(..) , module Urbit.King.Config ) @@ -125,7 +125,7 @@ killKingActionL :: HasKingEnv e => Getter e (STM ()) killKingActionL = kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ())) --- RunningEnv ------------------------------------------------------------------ +-- HostEnv ------------------------------------------------------------------ -- The running environment is everything in King, eyre configuration shared -- across ships, and IP information shared across ships. @@ -136,60 +136,60 @@ class HasMultiEyreApi a where multiEyreApiL :: Lens' a MultiEyreApi class (HasKingEnv a, HasMultiEyreApi a, HasPortControlApi a) => - HasRunningEnv a where - runningEnvL :: Lens' a RunningEnv + HasHostEnv a where + hostEnvL :: Lens' a HostEnv -data RunningEnv = RunningEnv - { _runningEnvKingEnv :: !KingEnv - , _runningEnvMultiEyreApi :: MultiEyreApi - , _runningEnvPortControlApi :: PortControlApi +data HostEnv = HostEnv + { _hostEnvKingEnv :: !KingEnv + , _hostEnvMultiEyreApi :: MultiEyreApi + , _hostEnvPortControlApi :: PortControlApi } -makeLenses ''RunningEnv +makeLenses ''HostEnv -instance HasKingEnv RunningEnv where - kingEnvL = runningEnvKingEnv +instance HasKingEnv HostEnv where + kingEnvL = hostEnvKingEnv -instance HasLogFunc RunningEnv where +instance HasLogFunc HostEnv where logFuncL = kingEnvL . logFuncL -instance HasStderrLogFunc RunningEnv where +instance HasStderrLogFunc HostEnv where stderrLogFuncL = kingEnvL . stderrLogFuncL -instance HasProcId RunningEnv where +instance HasProcId HostEnv where procIdL = kingEnvL . procIdL -instance HasKingId RunningEnv where +instance HasKingId HostEnv where kingIdL = kingEnvL . kingEnvKingId -instance HasMultiEyreApi RunningEnv where - multiEyreApiL = runningEnvMultiEyreApi +instance HasMultiEyreApi HostEnv where + multiEyreApiL = hostEnvMultiEyreApi -instance HasPortControlApi RunningEnv where - portControlApiL = runningEnvPortControlApi +instance HasPortControlApi HostEnv where + portControlApiL = hostEnvPortControlApi -- Running Running Envs -------------------------------------------------------- -runRunningEnv :: MultiEyreApi -> PortControlApi -> RIO RunningEnv () +runHostEnv :: MultiEyreApi -> PortControlApi -> RIO HostEnv () -> RIO KingEnv () -runRunningEnv multi ports action = do +runHostEnv multi ports action = do king <- ask - let runningEnv = RunningEnv { _runningEnvKingEnv = king - , _runningEnvMultiEyreApi = multi - , _runningEnvPortControlApi = ports + let hostEnv = HostEnv { _hostEnvKingEnv = king + , _hostEnvMultiEyreApi = multi + , _hostEnvPortControlApi = ports } - io (runRIO runningEnv action) + io (runRIO hostEnv action) -- PierEnv --------------------------------------------------------------------- -class (HasKingEnv a, HasRunningEnv a, HasPierConfig a, HasNetworkConfig a) => +class (HasKingEnv a, HasHostEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where pierEnvL :: Lens' a PierEnv data PierEnv = PierEnv - { _pierEnvRunningEnv :: !RunningEnv + { _pierEnvHostEnv :: !HostEnv , _pierEnvPierConfig :: !PierConfig , _pierEnvNetworkConfig :: !NetworkConfig , _pierEnvKillSignal :: !(TMVar ()) @@ -198,16 +198,16 @@ data PierEnv = PierEnv makeLenses ''PierEnv instance HasKingEnv PierEnv where - kingEnvL = pierEnvRunningEnv . kingEnvL + kingEnvL = pierEnvHostEnv . kingEnvL -instance HasRunningEnv PierEnv where - runningEnvL = pierEnvRunningEnv +instance HasHostEnv PierEnv where + hostEnvL = pierEnvHostEnv instance HasMultiEyreApi PierEnv where - multiEyreApiL = pierEnvRunningEnv . multiEyreApiL + multiEyreApiL = pierEnvHostEnv . multiEyreApiL instance HasPortControlApi PierEnv where - portControlApiL = pierEnvRunningEnv . portControlApiL + portControlApiL = pierEnvHostEnv . portControlApiL instance HasPierEnv PierEnv where pierEnvL = id @@ -250,11 +250,11 @@ killPierActionL = -- Running Pier Envs ----------------------------------------------------------- runPierEnv - :: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO RunningEnv a + :: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO HostEnv a runPierEnv pierConfig networkConfig vKill action = do running <- ask - let pierEnv = PierEnv { _pierEnvRunningEnv = running + let pierEnv = PierEnv { _pierEnvHostEnv = running , _pierEnvPierConfig = pierConfig , _pierEnvNetworkConfig = networkConfig , _pierEnvKillSignal = vKill diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index 03b4d90ed3..502134a190 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -443,7 +443,7 @@ validateNounVal inpVal = do -------------------------------------------------------------------------------- -pillFrom :: CLI.PillSource -> RIO RunningEnv Pill +pillFrom :: CLI.PillSource -> RIO HostEnv Pill pillFrom = \case CLI.PillSourceFile pillPath -> do logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text) @@ -479,9 +479,9 @@ newShip CLI.New{..} opts = do let ports = buildInactivePorts -- here we are with a king env, and we now need a multi env. - runRunningEnv multi ports go + runHostEnv multi ports go where - go :: RIO RunningEnv () + go :: RIO HostEnv () go = case nBootType of CLI.BootComet -> do pill <- pillFrom nPillSource @@ -515,7 +515,7 @@ newShip CLI.New{..} opts = do bootFromSeed pill seed - shipFrom :: Text -> RIO RunningEnv Ship + shipFrom :: Text -> RIO HostEnv Ship shipFrom name = case Ob.parsePatp name of Left x -> error "Invalid ship name" Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p @@ -525,7 +525,7 @@ newShip CLI.New{..} opts = do Just x -> x Nothing -> "./" <> unpack name - nameFromShip :: Ship -> RIO RunningEnv Text + nameFromShip :: Ship -> RIO HostEnv Text nameFromShip s = name where nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s @@ -533,7 +533,7 @@ newShip CLI.New{..} opts = do Nothing -> error "Urbit.ob didn't produce string with ~" Just x -> pure x - bootFromSeed :: Pill -> Seed -> RIO RunningEnv () + bootFromSeed :: Pill -> Seed -> RIO HostEnv () bootFromSeed pill seed = do ethReturn <- dawnVent seed @@ -547,7 +547,7 @@ newShip CLI.New{..} opts = do -- Now that we have all the information for running an application with a -- PierConfig, do so. runTryBootFromPill :: Pill -> Text -> Ship -> LegacyBootEvent - -> RIO RunningEnv () + -> RIO HostEnv () runTryBootFromPill pill name ship bootEvent = do env <- ask let vKill = (env ^. kingEnvL) ^. kingEnvKillSignal @@ -557,7 +557,7 @@ newShip CLI.New{..} opts = do tryBootFromPill True pill nLite ship bootEvent ------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent -runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO RunningEnv a +runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO HostEnv a runShipEnv (CLI.Run pierPath) opts vKill act = do runPierEnv pierConfig netConfig vKill act where @@ -689,7 +689,7 @@ main = do TODO Use logging system instead of printing. -} runShipRestarting - :: CLI.Run -> CLI.Opts -> RIO RunningEnv () + :: CLI.Run -> CLI.Opts -> RIO HostEnv () runShipRestarting r o = do let pier = pack (CLI.rPierPath r) loop = runShipRestarting r o @@ -722,7 +722,7 @@ runShipRestarting r o = do TODO This is messy and shared a lot of logic with `runShipRestarting`. -} runShipNoRestart - :: CLI.Run -> CLI.Opts -> Bool -> RIO RunningEnv () + :: CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv () runShipNoRestart r o d = do -- killing ship same as killing king env <- ask @@ -761,9 +761,9 @@ runShips CLI.KingOpts {..} ships = do ports <- buildPortHandler koUseNatPmp - runRunningEnv multi ports (go ships) + runHostEnv multi ports (go ships) where - go :: [(CLI.Run, CLI.Opts, Bool)] -> RIO RunningEnv () + go :: [(CLI.Run, CLI.Opts, Bool)] -> RIO HostEnv () go = \case [] -> pure () [rod] -> runSingleShip rod @@ -771,7 +771,7 @@ runShips CLI.KingOpts {..} ships = do -- TODO Duplicated logic. -runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> RIO RunningEnv () +runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> RIO HostEnv () runSingleShip (r, o, d) = do shipThread <- async (runShipNoRestart r o d) @@ -793,7 +793,7 @@ runSingleShip (r, o, d) = do pure () -runMultipleShips :: [(CLI.Run, CLI.Opts)] -> RIO RunningEnv () +runMultipleShips :: [(CLI.Run, CLI.Opts)] -> RIO HostEnv () runMultipleShips ships = do shipThreads <- for ships $ \(r, o) -> do async (runShipRestarting r o)