mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-11-14 04:19:22 +03:00
king: move MultiEyreApi to a new RunningEnv.
There was a TODO in runShips about how the different layers of the RIO environment had to be changed, so that there was a layer between KingEnv and PierEnv for things shared between individual Piers, but which weren't used outside of any PierEnv. This addresses those TODOs by creating RunningEnv, which for now just owns MultiEyreApi and makes it so we don't have to pass the entire thing around explicitly. The IP handling stuff will go in RunningEnv in a following patch.
This commit is contained in:
parent
225d2a288b
commit
d39d7246d1
@ -9,6 +9,8 @@ module Urbit.King.App
|
|||||||
, kingEnvKillSignal
|
, kingEnvKillSignal
|
||||||
, killKingActionL
|
, killKingActionL
|
||||||
, onKillKingSigL
|
, onKillKingSigL
|
||||||
|
, RunningEnv
|
||||||
|
, runRunningEnv
|
||||||
, PierEnv
|
, PierEnv
|
||||||
, runPierEnv
|
, runPierEnv
|
||||||
, killPierActionL
|
, killPierActionL
|
||||||
@ -17,6 +19,8 @@ module Urbit.King.App
|
|||||||
, HasKingId(..)
|
, HasKingId(..)
|
||||||
, HasProcId(..)
|
, HasProcId(..)
|
||||||
, HasKingEnv(..)
|
, HasKingEnv(..)
|
||||||
|
, HasMultiEyreApi(..)
|
||||||
|
, HasRunningEnv(..)
|
||||||
, HasPierEnv(..)
|
, HasPierEnv(..)
|
||||||
, module Urbit.King.Config
|
, module Urbit.King.Config
|
||||||
)
|
)
|
||||||
@ -30,6 +34,7 @@ import System.Posix.Internals (c_getpid)
|
|||||||
import System.Posix.Types (CPid(..))
|
import System.Posix.Types (CPid(..))
|
||||||
import System.Random (randomIO)
|
import System.Random (randomIO)
|
||||||
import Urbit.King.App.Class (HasStderrLogFunc(..))
|
import Urbit.King.App.Class (HasStderrLogFunc(..))
|
||||||
|
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
|
||||||
|
|
||||||
|
|
||||||
-- KingEnv ---------------------------------------------------------------------
|
-- KingEnv ---------------------------------------------------------------------
|
||||||
@ -70,7 +75,6 @@ instance HasProcId KingEnv where
|
|||||||
instance HasKingId KingEnv where
|
instance HasKingId KingEnv where
|
||||||
kingIdL = kingEnvKingId
|
kingIdL = kingEnvKingId
|
||||||
|
|
||||||
|
|
||||||
-- Running KingEnvs ------------------------------------------------------------
|
-- Running KingEnvs ------------------------------------------------------------
|
||||||
|
|
||||||
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
|
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
|
||||||
@ -121,14 +125,64 @@ killKingActionL :: HasKingEnv e => Getter e (STM ())
|
|||||||
killKingActionL =
|
killKingActionL =
|
||||||
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
|
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
|
||||||
|
|
||||||
|
-- RunningEnv ------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- The running environment is everything in King, eyre configuration shared
|
||||||
|
-- across ships, and IP information shared across ships.
|
||||||
|
--
|
||||||
|
-- TODO: Implement that IP information for real.
|
||||||
|
|
||||||
|
class HasMultiEyreApi a where
|
||||||
|
multiEyreApiL :: Lens' a MultiEyreApi
|
||||||
|
|
||||||
|
class (HasKingEnv a, HasMultiEyreApi a) => HasRunningEnv a where
|
||||||
|
runningEnvL :: Lens' a RunningEnv
|
||||||
|
|
||||||
|
data RunningEnv = RunningEnv
|
||||||
|
{ _runningEnvKingEnv :: !KingEnv
|
||||||
|
, _runningEnvMultiEyreApi :: MultiEyreApi
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses ''RunningEnv
|
||||||
|
|
||||||
|
instance HasKingEnv RunningEnv where
|
||||||
|
kingEnvL = runningEnvKingEnv
|
||||||
|
|
||||||
|
instance HasLogFunc RunningEnv where
|
||||||
|
logFuncL = kingEnvL . logFuncL
|
||||||
|
|
||||||
|
instance HasStderrLogFunc RunningEnv where
|
||||||
|
stderrLogFuncL = kingEnvL . stderrLogFuncL
|
||||||
|
|
||||||
|
instance HasProcId RunningEnv where
|
||||||
|
procIdL = kingEnvL . procIdL
|
||||||
|
|
||||||
|
instance HasKingId RunningEnv where
|
||||||
|
kingIdL = kingEnvL . kingEnvKingId
|
||||||
|
|
||||||
|
instance HasMultiEyreApi RunningEnv where
|
||||||
|
multiEyreApiL = runningEnvMultiEyreApi
|
||||||
|
|
||||||
|
-- Running Running Envs --------------------------------------------------------
|
||||||
|
|
||||||
|
runRunningEnv :: MultiEyreApi -> RIO RunningEnv () -> RIO KingEnv ()
|
||||||
|
runRunningEnv multi action = do
|
||||||
|
king <- ask
|
||||||
|
|
||||||
|
let runningEnv = RunningEnv { _runningEnvKingEnv = king
|
||||||
|
, _runningEnvMultiEyreApi = multi
|
||||||
|
}
|
||||||
|
|
||||||
|
io (runRIO runningEnv action)
|
||||||
|
|
||||||
-- PierEnv ---------------------------------------------------------------------
|
-- PierEnv ---------------------------------------------------------------------
|
||||||
|
|
||||||
class (HasKingEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where
|
class (HasKingEnv a, HasRunningEnv a, HasPierConfig a, HasNetworkConfig a) =>
|
||||||
|
HasPierEnv a where
|
||||||
pierEnvL :: Lens' a PierEnv
|
pierEnvL :: Lens' a PierEnv
|
||||||
|
|
||||||
data PierEnv = PierEnv
|
data PierEnv = PierEnv
|
||||||
{ _pierEnvKingEnv :: !KingEnv
|
{ _pierEnvRunningEnv :: !RunningEnv
|
||||||
, _pierEnvPierConfig :: !PierConfig
|
, _pierEnvPierConfig :: !PierConfig
|
||||||
, _pierEnvNetworkConfig :: !NetworkConfig
|
, _pierEnvNetworkConfig :: !NetworkConfig
|
||||||
, _pierEnvKillSignal :: !(TMVar ())
|
, _pierEnvKillSignal :: !(TMVar ())
|
||||||
@ -137,7 +191,13 @@ data PierEnv = PierEnv
|
|||||||
makeLenses ''PierEnv
|
makeLenses ''PierEnv
|
||||||
|
|
||||||
instance HasKingEnv PierEnv where
|
instance HasKingEnv PierEnv where
|
||||||
kingEnvL = pierEnvKingEnv
|
kingEnvL = pierEnvRunningEnv . kingEnvL
|
||||||
|
|
||||||
|
instance HasRunningEnv PierEnv where
|
||||||
|
runningEnvL = pierEnvRunningEnv
|
||||||
|
|
||||||
|
instance HasMultiEyreApi PierEnv where
|
||||||
|
multiEyreApiL = pierEnvRunningEnv . multiEyreApiL
|
||||||
|
|
||||||
instance HasPierEnv PierEnv where
|
instance HasPierEnv PierEnv where
|
||||||
pierEnvL = id
|
pierEnvL = id
|
||||||
@ -180,11 +240,11 @@ killPierActionL =
|
|||||||
-- Running Pier Envs -----------------------------------------------------------
|
-- Running Pier Envs -----------------------------------------------------------
|
||||||
|
|
||||||
runPierEnv
|
runPierEnv
|
||||||
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
|
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO RunningEnv a
|
||||||
runPierEnv pierConfig networkConfig vKill action = do
|
runPierEnv pierConfig networkConfig vKill action = do
|
||||||
app <- ask
|
running <- ask
|
||||||
|
|
||||||
let pierEnv = PierEnv { _pierEnvKingEnv = app
|
let pierEnv = PierEnv { _pierEnvRunningEnv = running
|
||||||
, _pierEnvPierConfig = pierConfig
|
, _pierEnvPierConfig = pierConfig
|
||||||
, _pierEnvNetworkConfig = networkConfig
|
, _pierEnvNetworkConfig = networkConfig
|
||||||
, _pierEnvKillSignal = vKill
|
, _pierEnvKillSignal = vKill
|
||||||
|
@ -82,7 +82,7 @@ import Urbit.Arvo
|
|||||||
import Urbit.King.Config
|
import Urbit.King.Config
|
||||||
import Urbit.Vere.Dawn
|
import Urbit.Vere.Dawn
|
||||||
import Urbit.Vere.Pier
|
import Urbit.Vere.Pier
|
||||||
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..))
|
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreConf(..))
|
||||||
import Urbit.Vere.Pier.Types
|
import Urbit.Vere.Pier.Types
|
||||||
import Urbit.Vere.Serf
|
import Urbit.Vere.Serf
|
||||||
import Urbit.King.App
|
import Urbit.King.App
|
||||||
@ -184,12 +184,11 @@ tryBootFromPill
|
|||||||
-> Bool
|
-> Bool
|
||||||
-> Ship
|
-> Ship
|
||||||
-> LegacyBootEvent
|
-> LegacyBootEvent
|
||||||
-> MultiEyreApi
|
|
||||||
-> RIO PierEnv ()
|
-> RIO PierEnv ()
|
||||||
tryBootFromPill oExit pill lite ship boot multi = do
|
tryBootFromPill oExit pill lite ship boot = do
|
||||||
mStart <- newEmptyMVar
|
mStart <- newEmptyMVar
|
||||||
vSlog <- logSlogs
|
vSlog <- logSlogs
|
||||||
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
|
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart
|
||||||
where
|
where
|
||||||
bootedPier vSlog = do
|
bootedPier vSlog = do
|
||||||
view pierPathL >>= lockFile
|
view pierPathL >>= lockFile
|
||||||
@ -203,9 +202,8 @@ runOrExitImmediately
|
|||||||
-> RAcquire PierEnv (Serf, Log.EventLog)
|
-> RAcquire PierEnv (Serf, Log.EventLog)
|
||||||
-> Bool
|
-> Bool
|
||||||
-> MVar ()
|
-> MVar ()
|
||||||
-> MultiEyreApi
|
|
||||||
-> RIO PierEnv ()
|
-> RIO PierEnv ()
|
||||||
runOrExitImmediately vSlog getPier oExit mStart multi = do
|
runOrExitImmediately vSlog getPier oExit mStart = do
|
||||||
rwith getPier (if oExit then shutdownImmediately else runPier)
|
rwith getPier (if oExit then shutdownImmediately else runPier)
|
||||||
where
|
where
|
||||||
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
||||||
@ -216,19 +214,18 @@ runOrExitImmediately vSlog getPier oExit mStart multi = do
|
|||||||
|
|
||||||
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
||||||
runPier serfLog = do
|
runPier serfLog = do
|
||||||
runRAcquire (Pier.pier serfLog vSlog mStart multi)
|
runRAcquire (Pier.pier serfLog vSlog mStart)
|
||||||
|
|
||||||
tryPlayShip
|
tryPlayShip
|
||||||
:: Bool
|
:: Bool
|
||||||
-> Bool
|
-> Bool
|
||||||
-> Maybe Word64
|
-> Maybe Word64
|
||||||
-> MVar ()
|
-> MVar ()
|
||||||
-> MultiEyreApi
|
|
||||||
-> RIO PierEnv ()
|
-> RIO PierEnv ()
|
||||||
tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
|
tryPlayShip exitImmediately fullReplay playFrom mStart = do
|
||||||
when fullReplay wipeSnapshot
|
when fullReplay wipeSnapshot
|
||||||
vSlog <- logSlogs
|
vSlog <- logSlogs
|
||||||
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
|
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart
|
||||||
where
|
where
|
||||||
wipeSnapshot = do
|
wipeSnapshot = do
|
||||||
shipPath <- view pierPathL
|
shipPath <- view pierPathL
|
||||||
@ -444,7 +441,7 @@ validateNounVal inpVal = do
|
|||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
pillFrom :: CLI.PillSource -> RIO KingEnv Pill
|
pillFrom :: CLI.PillSource -> RIO RunningEnv Pill
|
||||||
pillFrom = \case
|
pillFrom = \case
|
||||||
CLI.PillSourceFile pillPath -> do
|
CLI.PillSourceFile pillPath -> do
|
||||||
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
|
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
|
||||||
@ -475,41 +472,44 @@ newShip CLI.New{..} opts = do
|
|||||||
-}
|
-}
|
||||||
multi <- multiEyre (MultiEyreConf Nothing Nothing True)
|
multi <- multiEyre (MultiEyreConf Nothing Nothing True)
|
||||||
|
|
||||||
case nBootType of
|
-- here we are with a king env, and we now need a multi env.
|
||||||
CLI.BootComet -> do
|
runRunningEnv multi go
|
||||||
pill <- pillFrom nPillSource
|
|
||||||
putStrLn "boot: retrieving list of stars currently accepting comets"
|
|
||||||
starList <- dawnCometList
|
|
||||||
putStrLn ("boot: " ++ (tshow $ length starList) ++
|
|
||||||
" star(s) currently accepting comets")
|
|
||||||
putStrLn "boot: mining a comet"
|
|
||||||
eny <- io $ Sys.randomIO
|
|
||||||
let seed = mineComet (Set.fromList starList) eny
|
|
||||||
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
|
|
||||||
bootFromSeed multi pill seed
|
|
||||||
|
|
||||||
CLI.BootFake name -> do
|
|
||||||
pill <- pillFrom nPillSource
|
|
||||||
ship <- shipFrom name
|
|
||||||
runTryBootFromPill multi pill name ship (Fake ship)
|
|
||||||
|
|
||||||
CLI.BootFromKeyfile keyFile -> do
|
|
||||||
text <- readFileUtf8 keyFile
|
|
||||||
asAtom <- case cordToUW (Cord $ T.strip text) of
|
|
||||||
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
|
|
||||||
Just (UW a) -> pure a
|
|
||||||
|
|
||||||
asNoun <- cueExn asAtom
|
|
||||||
seed :: Seed <- case fromNoun asNoun of
|
|
||||||
Nothing -> error "Keyfile does not seem to contain a seed."
|
|
||||||
Just s -> pure s
|
|
||||||
|
|
||||||
pill <- pillFrom nPillSource
|
|
||||||
|
|
||||||
bootFromSeed multi pill seed
|
|
||||||
|
|
||||||
where
|
where
|
||||||
shipFrom :: Text -> RIO KingEnv Ship
|
go :: RIO RunningEnv ()
|
||||||
|
go = case nBootType of
|
||||||
|
CLI.BootComet -> do
|
||||||
|
pill <- pillFrom nPillSource
|
||||||
|
putStrLn "boot: retrieving list of stars currently accepting comets"
|
||||||
|
starList <- dawnCometList
|
||||||
|
putStrLn ("boot: " ++ (tshow $ length starList) ++
|
||||||
|
" star(s) currently accepting comets")
|
||||||
|
putStrLn "boot: mining a comet"
|
||||||
|
eny <- io $ Sys.randomIO
|
||||||
|
let seed = mineComet (Set.fromList starList) eny
|
||||||
|
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
|
||||||
|
bootFromSeed pill seed
|
||||||
|
|
||||||
|
CLI.BootFake name -> do
|
||||||
|
pill <- pillFrom nPillSource
|
||||||
|
ship <- shipFrom name
|
||||||
|
runTryBootFromPill pill name ship (Fake ship)
|
||||||
|
|
||||||
|
CLI.BootFromKeyfile keyFile -> do
|
||||||
|
text <- readFileUtf8 keyFile
|
||||||
|
asAtom <- case cordToUW (Cord $ T.strip text) of
|
||||||
|
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
|
||||||
|
Just (UW a) -> pure a
|
||||||
|
|
||||||
|
asNoun <- cueExn asAtom
|
||||||
|
seed :: Seed <- case fromNoun asNoun of
|
||||||
|
Nothing -> error "Keyfile does not seem to contain a seed."
|
||||||
|
Just s -> pure s
|
||||||
|
|
||||||
|
pill <- pillFrom nPillSource
|
||||||
|
|
||||||
|
bootFromSeed pill seed
|
||||||
|
|
||||||
|
shipFrom :: Text -> RIO RunningEnv Ship
|
||||||
shipFrom name = case Ob.parsePatp name of
|
shipFrom name = case Ob.parsePatp name of
|
||||||
Left x -> error "Invalid ship name"
|
Left x -> error "Invalid ship name"
|
||||||
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
|
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
|
||||||
@ -519,7 +519,7 @@ newShip CLI.New{..} opts = do
|
|||||||
Just x -> x
|
Just x -> x
|
||||||
Nothing -> "./" <> unpack name
|
Nothing -> "./" <> unpack name
|
||||||
|
|
||||||
nameFromShip :: Ship -> RIO KingEnv Text
|
nameFromShip :: Ship -> RIO RunningEnv Text
|
||||||
nameFromShip s = name
|
nameFromShip s = name
|
||||||
where
|
where
|
||||||
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
|
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
|
||||||
@ -527,8 +527,8 @@ newShip CLI.New{..} opts = do
|
|||||||
Nothing -> error "Urbit.ob didn't produce string with ~"
|
Nothing -> error "Urbit.ob didn't produce string with ~"
|
||||||
Just x -> pure x
|
Just x -> pure x
|
||||||
|
|
||||||
bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO KingEnv ()
|
bootFromSeed :: Pill -> Seed -> RIO RunningEnv ()
|
||||||
bootFromSeed multi pill seed = do
|
bootFromSeed pill seed = do
|
||||||
ethReturn <- dawnVent seed
|
ethReturn <- dawnVent seed
|
||||||
|
|
||||||
case ethReturn of
|
case ethReturn of
|
||||||
@ -536,19 +536,22 @@ newShip CLI.New{..} opts = do
|
|||||||
Right dawn -> do
|
Right dawn -> do
|
||||||
let ship = sShip $ dSeed dawn
|
let ship = sShip $ dSeed dawn
|
||||||
name <- nameFromShip ship
|
name <- nameFromShip ship
|
||||||
runTryBootFromPill multi pill name ship (Dawn dawn)
|
runTryBootFromPill pill name ship (Dawn dawn)
|
||||||
|
|
||||||
-- Now that we have all the information for running an application with a
|
-- Now that we have all the information for running an application with a
|
||||||
-- PierConfig, do so.
|
-- PierConfig, do so.
|
||||||
runTryBootFromPill multi pill name ship bootEvent = do
|
runTryBootFromPill :: Pill -> Text -> Ship -> LegacyBootEvent
|
||||||
vKill <- view kingEnvKillSignal
|
-> RIO RunningEnv ()
|
||||||
|
runTryBootFromPill pill name ship bootEvent = do
|
||||||
|
env <- ask
|
||||||
|
let vKill = (env ^. kingEnvL) ^. kingEnvKillSignal
|
||||||
let pierConfig = toPierConfig (pierPath name) opts
|
let pierConfig = toPierConfig (pierPath name) opts
|
||||||
let networkConfig = toNetworkConfig opts
|
let networkConfig = toNetworkConfig opts
|
||||||
runPierEnv pierConfig networkConfig vKill $
|
runPierEnv pierConfig networkConfig vKill $
|
||||||
tryBootFromPill True pill nLite ship bootEvent multi
|
tryBootFromPill True pill nLite ship bootEvent
|
||||||
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
|
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
|
||||||
|
|
||||||
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
|
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO RunningEnv a
|
||||||
runShipEnv (CLI.Run pierPath) opts vKill act = do
|
runShipEnv (CLI.Run pierPath) opts vKill act = do
|
||||||
runPierEnv pierConfig netConfig vKill act
|
runPierEnv pierConfig netConfig vKill act
|
||||||
where
|
where
|
||||||
@ -556,8 +559,8 @@ runShipEnv (CLI.Run pierPath) opts vKill act = do
|
|||||||
netConfig = toNetworkConfig opts
|
netConfig = toNetworkConfig opts
|
||||||
|
|
||||||
runShip
|
runShip
|
||||||
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv ()
|
:: CLI.Run -> CLI.Opts -> Bool -> RIO PierEnv ()
|
||||||
runShip (CLI.Run pierPath) opts daemon multi = do
|
runShip (CLI.Run pierPath) opts daemon = do
|
||||||
mStart <- newEmptyMVar
|
mStart <- newEmptyMVar
|
||||||
if daemon
|
if daemon
|
||||||
then runPier mStart
|
then runPier mStart
|
||||||
@ -580,7 +583,6 @@ runShip (CLI.Run pierPath) opts daemon multi = do
|
|||||||
(CLI.oFullReplay opts)
|
(CLI.oFullReplay opts)
|
||||||
(CLI.oDryFrom opts)
|
(CLI.oDryFrom opts)
|
||||||
mStart
|
mStart
|
||||||
multi
|
|
||||||
|
|
||||||
|
|
||||||
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
|
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
|
||||||
@ -674,15 +676,15 @@ main = do
|
|||||||
TODO Use logging system instead of printing.
|
TODO Use logging system instead of printing.
|
||||||
-}
|
-}
|
||||||
runShipRestarting
|
runShipRestarting
|
||||||
:: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
|
:: CLI.Run -> CLI.Opts -> RIO RunningEnv ()
|
||||||
runShipRestarting r o multi = do
|
runShipRestarting r o = do
|
||||||
let pier = pack (CLI.rPierPath r)
|
let pier = pack (CLI.rPierPath r)
|
||||||
loop = runShipRestarting r o multi
|
loop = runShipRestarting r o
|
||||||
|
|
||||||
onKill <- view onKillKingSigL
|
onKill <- view onKillKingSigL
|
||||||
vKillPier <- newEmptyTMVarIO
|
vKillPier <- newEmptyTMVarIO
|
||||||
|
|
||||||
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi
|
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True
|
||||||
|
|
||||||
let onShipExit = Left <$> waitCatchSTM tid
|
let onShipExit = Left <$> waitCatchSTM tid
|
||||||
onKillRequ = Right <$> onKill
|
onKillRequ = Right <$> onKill
|
||||||
@ -707,10 +709,12 @@ runShipRestarting r o multi = do
|
|||||||
TODO This is messy and shared a lot of logic with `runShipRestarting`.
|
TODO This is messy and shared a lot of logic with `runShipRestarting`.
|
||||||
-}
|
-}
|
||||||
runShipNoRestart
|
runShipNoRestart
|
||||||
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv ()
|
:: CLI.Run -> CLI.Opts -> Bool -> RIO RunningEnv ()
|
||||||
runShipNoRestart r o d multi = do
|
runShipNoRestart r o d = do
|
||||||
vKill <- view kingEnvKillSignal -- killing ship same as killing king
|
-- killing ship same as killing king
|
||||||
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d multi)
|
env <- ask
|
||||||
|
let vKill = (env ^. kingEnvL) ^. kingEnvKillSignal
|
||||||
|
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d)
|
||||||
onKill <- view onKillKingSigL
|
onKill <- view onKillKingSigL
|
||||||
|
|
||||||
let pier = pack (CLI.rPierPath r)
|
let pier = pack (CLI.rPierPath r)
|
||||||
@ -740,31 +744,21 @@ runShips CLI.KingOpts {..} ships = do
|
|||||||
-- a king-wide option.
|
-- a king-wide option.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
{-
|
|
||||||
TODO Need to rework RIO environment to fix this. Should have a
|
|
||||||
bunch of nested contexts:
|
|
||||||
|
|
||||||
- King has started. King has Id. Logging available.
|
|
||||||
- In running environment. MultiEyre and global config available.
|
|
||||||
- In pier environment: pier path and config available.
|
|
||||||
- In running ship environment: serf state, event queue available.
|
|
||||||
-}
|
|
||||||
multi <- multiEyre meConf
|
multi <- multiEyre meConf
|
||||||
|
|
||||||
go multi ships
|
runRunningEnv multi (go ships)
|
||||||
where
|
where
|
||||||
go :: MultiEyreApi -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
|
go :: [(CLI.Run, CLI.Opts, Bool)] -> RIO RunningEnv ()
|
||||||
go me = \case
|
go = \case
|
||||||
[] -> pure ()
|
[] -> pure ()
|
||||||
[rod] -> runSingleShip rod me
|
[rod] -> runSingleShip rod
|
||||||
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
|
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o))
|
||||||
|
|
||||||
|
|
||||||
-- TODO Duplicated logic.
|
-- TODO Duplicated logic.
|
||||||
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> MultiEyreApi -> RIO KingEnv ()
|
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> RIO RunningEnv ()
|
||||||
runSingleShip (r, o, d) multi = do
|
runSingleShip (r, o, d) = do
|
||||||
shipThread <- async (runShipNoRestart r o d multi)
|
shipThread <- async (runShipNoRestart r o d)
|
||||||
|
|
||||||
{-
|
{-
|
||||||
Wait for the ship to go down.
|
Wait for the ship to go down.
|
||||||
@ -784,10 +778,10 @@ runSingleShip (r, o, d) multi = do
|
|||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv ()
|
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> RIO RunningEnv ()
|
||||||
runMultipleShips ships multi = do
|
runMultipleShips ships = do
|
||||||
shipThreads <- for ships $ \(r, o) -> do
|
shipThreads <- for ships $ \(r, o) -> do
|
||||||
async (runShipRestarting r o multi)
|
async (runShipRestarting r o)
|
||||||
|
|
||||||
{-
|
{-
|
||||||
Since `spin` never returns, this will run until the main
|
Since `spin` never returns, this will run until the main
|
||||||
|
@ -11,7 +11,7 @@ where
|
|||||||
import Urbit.Prelude hiding (Builder)
|
import Urbit.Prelude hiding (Builder)
|
||||||
|
|
||||||
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
|
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
|
||||||
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
|
import Urbit.King.App (HasKingId(..), HasMultiEyreApi(..), HasPierEnv(..))
|
||||||
import Urbit.King.Config
|
import Urbit.King.Config
|
||||||
import Urbit.Vere.Eyre.Multi
|
import Urbit.Vere.Eyre.Multi
|
||||||
import Urbit.Vere.Eyre.PortsFile
|
import Urbit.Vere.Eyre.PortsFile
|
||||||
@ -170,16 +170,18 @@ execRespActs (Drv v) who reqId ev = readMVar v >>= \case
|
|||||||
atomically (routeRespAct who (sLiveReqs sv) reqId act)
|
atomically (routeRespAct who (sLiveReqs sv) reqId act)
|
||||||
|
|
||||||
startServ
|
startServ
|
||||||
:: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
|
:: (HasPierConfig e, HasLogFunc e, HasMultiEyreApi e, HasNetworkConfig e)
|
||||||
=> MultiEyreApi
|
=> Ship
|
||||||
-> Ship
|
|
||||||
-> Bool
|
-> Bool
|
||||||
-> HttpServerConf
|
-> HttpServerConf
|
||||||
-> (EvErr -> STM ())
|
-> (EvErr -> STM ())
|
||||||
-> RIO e Serv
|
-> RIO e Serv
|
||||||
startServ multi who isFake conf plan = do
|
startServ who isFake conf plan = do
|
||||||
logDebug (displayShow ("EYRE", "startServ"))
|
logDebug (displayShow ("EYRE", "startServ"))
|
||||||
|
|
||||||
|
env <- ask
|
||||||
|
let multi = env ^. multiEyreApiL
|
||||||
|
|
||||||
let vLive = meaLive multi
|
let vLive = meaLive multi
|
||||||
|
|
||||||
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
|
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
|
||||||
@ -281,16 +283,15 @@ _bornFailed env _ = runRIO env $ do
|
|||||||
pure () -- TODO What should this do?
|
pure () -- TODO What should this do?
|
||||||
|
|
||||||
eyre'
|
eyre'
|
||||||
:: HasPierEnv e
|
:: (HasPierEnv e, HasMultiEyreApi e)
|
||||||
=> MultiEyreApi
|
=> Ship
|
||||||
-> Ship
|
|
||||||
-> Bool
|
-> Bool
|
||||||
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
|
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
|
||||||
eyre' multi who isFake = do
|
eyre' who isFake = do
|
||||||
ventQ :: TQueue EvErr <- newTQueueIO
|
ventQ :: TQueue EvErr <- newTQueueIO
|
||||||
env <- ask
|
env <- ask
|
||||||
|
|
||||||
let (bornEvs, startDriver) = eyre env multi who (writeTQueue ventQ) isFake
|
let (bornEvs, startDriver) = eyre env who (writeTQueue ventQ) isFake
|
||||||
|
|
||||||
let runDriver = do
|
let runDriver = do
|
||||||
diOnEffect <- startDriver
|
diOnEffect <- startDriver
|
||||||
@ -315,14 +316,14 @@ eyre
|
|||||||
:: forall e
|
:: forall e
|
||||||
. (HasPierEnv e)
|
. (HasPierEnv e)
|
||||||
=> e
|
=> e
|
||||||
-> MultiEyreApi
|
|
||||||
-> Ship
|
-> Ship
|
||||||
-> (EvErr -> STM ())
|
-> (EvErr -> STM ())
|
||||||
-> Bool
|
-> Bool
|
||||||
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
|
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
|
||||||
eyre env multi who plan isFake = (initialEvents, runHttpServer)
|
eyre env who plan isFake = (initialEvents, runHttpServer)
|
||||||
where
|
where
|
||||||
king = fromIntegral (env ^. kingIdL)
|
king = fromIntegral (env ^. kingIdL)
|
||||||
|
multi = env ^. multiEyreApiL
|
||||||
|
|
||||||
initialEvents :: [Ev]
|
initialEvents :: [Ev]
|
||||||
initialEvents = [bornEv king]
|
initialEvents = [bornEv king]
|
||||||
@ -343,7 +344,7 @@ eyre env multi who plan isFake = (initialEvents, runHttpServer)
|
|||||||
restart :: Drv -> HttpServerConf -> RIO e Serv
|
restart :: Drv -> HttpServerConf -> RIO e Serv
|
||||||
restart (Drv var) conf = do
|
restart (Drv var) conf = do
|
||||||
logDebug "Restarting http server"
|
logDebug "Restarting http server"
|
||||||
let startAct = startServ multi who isFake conf plan
|
let startAct = startServ who isFake conf plan
|
||||||
res <- fromEither =<< restartService var startAct kill
|
res <- fromEither =<< restartService var startAct kill
|
||||||
logDebug "Done restating http server"
|
logDebug "Done restating http server"
|
||||||
pure res
|
pure res
|
||||||
|
@ -30,7 +30,6 @@ import Urbit.EventLog.LMDB (EventLog)
|
|||||||
import Urbit.King.API (TermConn)
|
import Urbit.King.API (TermConn)
|
||||||
import Urbit.Noun.Time (Wen)
|
import Urbit.Noun.Time (Wen)
|
||||||
import Urbit.TermSize (TermSize(..))
|
import Urbit.TermSize (TermSize(..))
|
||||||
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
|
|
||||||
import Urbit.Vere.Serf (Serf)
|
import Urbit.Vere.Serf (Serf)
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
@ -260,9 +259,8 @@ pier
|
|||||||
:: (Serf, EventLog)
|
:: (Serf, EventLog)
|
||||||
-> TVar (Text -> IO ())
|
-> TVar (Text -> IO ())
|
||||||
-> MVar ()
|
-> MVar ()
|
||||||
-> MultiEyreApi
|
|
||||||
-> RAcquire PierEnv ()
|
-> RAcquire PierEnv ()
|
||||||
pier (serf, log) vSlog startedSig multi = do
|
pier (serf, log) vSlog startedSig = do
|
||||||
let logId = Log.identity log :: LogIdentity
|
let logId = Log.identity log :: LogIdentity
|
||||||
let ship = who logId :: Ship
|
let ship = who logId :: Ship
|
||||||
|
|
||||||
@ -311,7 +309,7 @@ pier (serf, log) vSlog startedSig multi = do
|
|||||||
let err = atomically . Term.trace muxed . (<> "\r\n")
|
let err = atomically . Term.trace muxed . (<> "\r\n")
|
||||||
let siz = TermSize { tsWide = 80, tsTall = 24 }
|
let siz = TermSize { tsWide = 80, tsTall = 24 }
|
||||||
let fak = isFake logId
|
let fak = isFake logId
|
||||||
drivers env multi ship fak compute (siz, muxed) err sigint
|
drivers env ship fak compute (siz, muxed) err sigint
|
||||||
|
|
||||||
scrySig <- newEmptyTMVarIO
|
scrySig <- newEmptyTMVarIO
|
||||||
onKill <- view onKillPierSigL
|
onKill <- view onKillPierSigL
|
||||||
@ -412,7 +410,6 @@ data Drivers = Drivers
|
|||||||
drivers
|
drivers
|
||||||
:: HasPierEnv e
|
:: HasPierEnv e
|
||||||
=> e
|
=> e
|
||||||
-> MultiEyreApi
|
|
||||||
-> Ship
|
-> Ship
|
||||||
-> Bool
|
-> Bool
|
||||||
-> (RunReq -> STM ())
|
-> (RunReq -> STM ())
|
||||||
@ -420,11 +417,11 @@ drivers
|
|||||||
-> (Text -> RIO e ())
|
-> (Text -> RIO e ())
|
||||||
-> IO ()
|
-> IO ()
|
||||||
-> RAcquire e ([Ev], RAcquire e Drivers)
|
-> RAcquire e ([Ev], RAcquire e Drivers)
|
||||||
drivers env multi who isFake plan termSys stderr serfSIGINT = do
|
drivers env who isFake plan termSys stderr serfSIGINT = do
|
||||||
(behnBorn, runBehn) <- rio Behn.behn'
|
(behnBorn, runBehn) <- rio Behn.behn'
|
||||||
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
|
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
|
||||||
(amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
|
(amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
|
||||||
(httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake)
|
(httpBorn, runEyre) <- rio (Eyre.eyre' who isFake)
|
||||||
(clayBorn, runClay) <- rio Clay.clay'
|
(clayBorn, runClay) <- rio Clay.clay'
|
||||||
(irisBorn, runIris) <- rio Iris.client'
|
(irisBorn, runIris) <- rio Iris.client'
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user