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:
Elliot Glaysher 2020-08-04 16:52:40 -04:00
parent 225d2a288b
commit d39d7246d1
4 changed files with 164 additions and 112 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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'