diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index 064d58a8cc..cf17992380 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -82,6 +82,7 @@ import Urbit.Arvo import Urbit.King.Config import Urbit.Vere.Dawn import Urbit.Vere.Pier +import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..)) import Urbit.Vere.Pier.Types import Urbit.Vere.Serf @@ -169,10 +170,11 @@ tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e ) => Bool -> Pill -> Bool -> Serf.Flags -> Ship -> LegacyBootEvent + -> MultiEyreApi -> RIO e () -tryBootFromPill oExit pill lite flags ship boot = do +tryBootFromPill oExit pill lite flags ship boot multi = do mStart <- newEmptyMVar - runOrExitImmediately bootedPier oExit mStart + runOrExitImmediately bootedPier oExit mStart multi where bootedPier = do view pierPathL >>= lockFile @@ -181,14 +183,14 @@ tryBootFromPill oExit pill lite flags ship boot = do rio $ logTrace "Completed boot" pure sls -runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e - , HasConfigDir e - ) - => RAcquire e (Serf e, Log.EventLog, SerfState) - -> Bool - -> MVar () - -> RIO e () -runOrExitImmediately getPier oExit mStart = +runOrExitImmediately + :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e, HasConfigDir e) + => RAcquire e (Serf e, Log.EventLog, SerfState) + -> Bool + -> MVar () + -> MultiEyreApi + -> RIO e () +runOrExitImmediately getPier oExit mStart multi = rwith getPier $ if oExit then shutdownImmediately else runPier where shutdownImmediately (serf, log, ss) = do @@ -203,15 +205,25 @@ runOrExitImmediately getPier oExit mStart = logTrace "Shutdown!" runPier sls = do - runRAcquire $ Pier.pier sls mStart + runRAcquire $ Pier.pier sls mStart multi -tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e - , HasPierConfig e, HasConfigDir e - ) - => Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e () -tryPlayShip exitImmediately fullReplay playFrom flags mStart = do +tryPlayShip + :: ( HasStderrLogFunc e + , HasLogFunc e + , HasNetworkConfig e + , HasPierConfig e + , HasConfigDir e + ) + => Bool + -> Bool + -> Maybe Word64 + -> Serf.Flags + -> MVar () + -> MultiEyreApi + -> RIO e () +tryPlayShip exitImmediately fullReplay playFrom flags mStart multi = do when fullReplay wipeSnapshot - runOrExitImmediately resumeShip exitImmediately mStart + runOrExitImmediately resumeShip exitImmediately mStart multi where wipeSnapshot = do shipPath <- view pierPathL @@ -422,7 +434,12 @@ pillFrom (CLI.PillSourceURL url) = do fromNounErr noun & either (throwIO . uncurry ParseErr) pure newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e () -newShip CLI.New{..} opts +newShip new opts = do + multi <- multiEyre (MultiEyreConf Nothing Nothing True) -- TODO Hack + newShip' multi new opts + +newShip' :: forall e. HasLogFunc e => MultiEyreApi -> CLI.New -> CLI.Opts -> RIO e () +newShip' multi CLI.New{..} opts | CLI.BootComet <- nBootType = do pill <- pillFrom nPillSource putStrLn "boot: retrieving list of stars currently accepting comets" @@ -493,12 +510,12 @@ newShip CLI.New{..} opts let pierConfig = toPierConfig (pierPath name) opts let networkConfig = toNetworkConfig opts io $ runPierApp pierConfig networkConfig True $ - tryBootFromPill True pill nLite flags ship bootEvent + tryBootFromPill True pill nLite flags ship bootEvent multi ------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent -runShip :: CLI.Run -> CLI.Opts -> Bool -> IO () -runShip (CLI.Run pierPath) opts daemon = do +runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> IO () +runShip (CLI.Run pierPath) opts daemon multi = do tid <- myThreadId let onTermExit = throwTo tid UserInterrupt mStart <- newEmptyMVar @@ -518,6 +535,7 @@ runShip (CLI.Run pierPath) opts daemon = do (CLI.oDryFrom opts) (toSerfFlags opts) mStart + multi pierConfig = toPierConfig pierPath opts networkConfig = toNetworkConfig opts @@ -591,12 +609,12 @@ main = do TODO Use logging system instead of printing. -} -runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> IO () -runShipRestarting waitForKillRequ r o = do +runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> IO () +runShipRestarting waitForKillRequ r o multi = do let pier = pack (CLI.rPierPath r) - loop = runShipRestarting waitForKillRequ r o + loop = runShipRestarting waitForKillRequ r o multi - tid <- asyncBound (runShip r o True) + tid <- asyncBound (runShip r o True multi) let onShipExit = Left <$> waitCatchSTM tid onKillRequ = Right <$> waitForKillRequ @@ -615,21 +633,40 @@ runShipRestarting waitForKillRequ r o = do runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> IO () -runShips CLI.KingOpts {..} = \case - [] -> pure () - [(r, o, d)] -> runShip r o d - ships | sharedHttp -> error "TODO Shared HTTP not yet implemented." - ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) - where sharedHttp = isJust koSharedHttpPort || isJust koSharedHttpsPort +runShips CLI.KingOpts {..} ships = do + let meConf = MultiEyreConf + { mecHttpPort = fromIntegral <$> koSharedHttpPort + , mecHttpsPort = fromIntegral <$> koSharedHttpsPort + , mecLocalhostOnly = False -- TODO Localhost-only needs to be + -- a king-wide option. + } -runMultipleShips :: [(CLI.Run, CLI.Opts)] -> IO () -runMultipleShips ships = do + {- + 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 <- runApp (multiEyre meConf) + + go multi ships + where + go me = \case + [] -> pure () + [(r, o, d)] -> runShip r o d me + ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me + +runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> IO () +runMultipleShips ships multi = do killSignal <- newEmptyTMVarIO let waitForKillRequ = readTMVar killSignal shipThreads <- for ships $ \(r, o) -> do - async (runShipRestarting waitForKillRequ r o) + async (runShipRestarting waitForKillRequ r o multi) {- Since `spin` never returns, this will run until the main diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs index 1fcc267d77..4b2b34ba91 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs @@ -4,7 +4,6 @@ module Urbit.Vere.Eyre ( eyre - , multiEyre ) where @@ -15,12 +14,12 @@ import Urbit.King.Config import Urbit.Vere.Eyre.PortsFile import Urbit.Vere.Eyre.Serv import Urbit.Vere.Eyre.Service +import Urbit.Vere.Eyre.Multi import Urbit.Vere.Eyre.Wai import Urbit.Vere.Pier.Types import Data.List.NonEmpty (NonEmpty((:|))) import Data.PEM (pemParseBS, pemWriteBS) -import Network.TLS (Credential) import RIO.Prelude (decodeUtf8Lenient) import System.Random (randomIO) import Urbit.Vere.Http (convertHeaders, unconvertHeaders) @@ -36,9 +35,6 @@ type ReqId = UD newtype Drv = Drv (MVar (Maybe Serv)) -data WhichServer = Secure | Insecure | Loopback - deriving (Eq) - data SockOpts = SockOpts { soLocalhost :: Bool , soWhich :: ServPort @@ -303,101 +299,3 @@ eyre king multi who plan isFake = (initialEvents, runHttpServer) HSEResponse (i, req, _seq, ()) ev -> do logDebug (displayShow ("EYRE", "%response")) execRespActs drv who (fromIntegral req) ev - - --- Multi-Tenet HTTP ------------------------------------------------------------ - -data MultiEyreConf = MultiEyreConf - { mecHttpsPort :: Maybe Port - , mecHttpPort :: Maybe Port - , mecLocalhostOnly :: Bool - } - -type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM () - -type OnMultiKil = Ship -> Word64 -> STM () - -data MultiEyreApi = MultiEyreApi - { meaConf :: MultiEyreConf - , meaLive :: TVar LiveReqs - , meaPlan :: TVar (Map Ship OnMultiReq) - , meaCanc :: TVar (Map Ship OnMultiKil) - , meaTlsC :: TVar (Map Ship Credential) - , meaKill :: STM () - } - -joinMultiEyre - :: MultiEyreApi - -> Ship - -> Maybe TlsConfig - -> OnMultiReq - -> OnMultiKil - -> STM () -joinMultiEyre api who mTls onReq onKil = do - modifyTVar' (meaPlan api) (insertMap who onReq) - modifyTVar' (meaCanc api) (insertMap who onKil) - for_ mTls $ \tls -> do - configCreds tls & \case - Left err -> pure () - Right cd -> modifyTVar' (meaTlsC api) (insertMap who cd) - -leaveMultiEyre :: MultiEyreApi -> Ship -> STM () -leaveMultiEyre MultiEyreApi {..} who = do - modifyTVar' meaCanc (deleteMap who) - modifyTVar' meaPlan (deleteMap who) - modifyTVar' meaTlsC (deleteMap who) - -multiEyre - :: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e) - => MultiEyreConf - -> RIO e MultiEyreApi -multiEyre conf@MultiEyreConf{..} = do - vLive <- newTVarIO emptyLiveReqs - vPlan <- newTVarIO mempty - vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ())) - vTlsC <- newTVarIO mempty - - let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk - - let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM () - onReq which who reqId reqInfo = do - plan <- readTVar vPlan - lookup who plan & \case - Nothing -> pure () - Just cb -> cb which who reqId reqInfo - - let onKil :: Ship -> Word64 -> STM () - onKil who reqId = do - canc <- readTVar vCanc - lookup who canc & \case - Nothing -> pure () - Just cb -> cb who reqId - - mIns <- for mecHttpPort $ \por -> serv vLive $ ServConf - { scHost = host - , scPort = SPChoices $ singleton $ fromIntegral por - , scRedi = Nothing -- TODO - , scType = STMultiHttp $ ReqApi - { rcReq = onReq Insecure - , rcKil = onKil - } - } - - mSec <- for mecHttpsPort $ \por -> serv vLive $ ServConf - { scHost = host - , scPort = SPChoices $ singleton $ fromIntegral por - , scRedi = Nothing - , scType = STMultiHttps vTlsC $ ReqApi - { rcReq = onReq Secure - , rcKil = onKil - } - } - - pure $ MultiEyreApi - { meaLive = vLive - , meaPlan = vPlan - , meaCanc = vCanc - , meaTlsC = vTlsC - , meaConf = conf - , meaKill = traverse_ saKil (toList mIns <> toList mSec) - } diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs new file mode 100644 index 0000000000..8aca5ab726 --- /dev/null +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs @@ -0,0 +1,124 @@ +{-| + Eyre: Http Server Driver +-} + +module Urbit.Vere.Eyre.Multi + ( WhichServer(..) + , MultiEyreConf(..) + , OnMultiReq + , OnMultiKil + , MultiEyreApi(..) + , joinMultiEyre + , leaveMultiEyre + , multiEyre + ) +where + +import Urbit.Prelude hiding (Builder) + +import Urbit.Arvo hiding (ServerId, reqUrl, secure) +import Urbit.Vere.Eyre.Serv +import Urbit.Vere.Eyre.Wai + +import Network.TLS (Credential) + + +-- Types ----------------------------------------------------------------------- + +data WhichServer = Secure | Insecure | Loopback + deriving (Eq) + +data MultiEyreConf = MultiEyreConf + { mecHttpsPort :: Maybe Port + , mecHttpPort :: Maybe Port + , mecLocalhostOnly :: Bool + } + +type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM () + +type OnMultiKil = Ship -> Word64 -> STM () + +data MultiEyreApi = MultiEyreApi + { meaConf :: MultiEyreConf + , meaLive :: TVar LiveReqs + , meaPlan :: TVar (Map Ship OnMultiReq) + , meaCanc :: TVar (Map Ship OnMultiKil) + , meaTlsC :: TVar (Map Ship Credential) + , meaKill :: STM () + } + + +-- Multi-Tenet HTTP ------------------------------------------------------------ + +joinMultiEyre + :: MultiEyreApi + -> Ship + -> Maybe TlsConfig + -> OnMultiReq + -> OnMultiKil + -> STM () +joinMultiEyre api who mTls onReq onKil = do + modifyTVar' (meaPlan api) (insertMap who onReq) + modifyTVar' (meaCanc api) (insertMap who onKil) + for_ mTls $ \tls -> do + configCreds tls & \case + Left err -> pure () + Right cd -> modifyTVar' (meaTlsC api) (insertMap who cd) + +leaveMultiEyre :: MultiEyreApi -> Ship -> STM () +leaveMultiEyre MultiEyreApi {..} who = do + modifyTVar' meaCanc (deleteMap who) + modifyTVar' meaPlan (deleteMap who) + modifyTVar' meaTlsC (deleteMap who) + +multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi +multiEyre conf@MultiEyreConf{..} = do + vLive <- newTVarIO emptyLiveReqs + vPlan <- newTVarIO mempty + vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ())) + vTlsC <- newTVarIO mempty + + let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk + + let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM () + onReq which who reqId reqInfo = do + plan <- readTVar vPlan + lookup who plan & \case + Nothing -> pure () + Just cb -> cb which who reqId reqInfo + + let onKil :: Ship -> Word64 -> STM () + onKil who reqId = do + canc <- readTVar vCanc + lookup who canc & \case + Nothing -> pure () + Just cb -> cb who reqId + + mIns <- for mecHttpPort $ \por -> serv vLive $ ServConf + { scHost = host + , scPort = SPChoices $ singleton $ fromIntegral por + , scRedi = Nothing -- TODO + , scType = STMultiHttp $ ReqApi + { rcReq = onReq Insecure + , rcKil = onKil + } + } + + mSec <- for mecHttpsPort $ \por -> serv vLive $ ServConf + { scHost = host + , scPort = SPChoices $ singleton $ fromIntegral por + , scRedi = Nothing + , scType = STMultiHttps vTlsC $ ReqApi + { rcReq = onReq Secure + , rcKil = onKil + } + } + + pure $ MultiEyreApi + { meaLive = vLive + , meaPlan = vPlan + , meaCanc = vCanc + , meaTlsC = vTlsC + , meaConf = conf + , meaKill = traverse_ saKil (toList mIns <> toList mSec) + } diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index abbb906d03..5635bb99e8 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -24,6 +24,7 @@ import Urbit.Vere.Ames (ames) import Urbit.Vere.Behn (behn) import Urbit.Vere.Clay (clay) import Urbit.Vere.Eyre (eyre) +import Urbit.Vere.Eyre.Multi (MultiEyreApi) import Urbit.Vere.Http.Client (client) import Urbit.Vere.Log (EventLog) import Urbit.Vere.Serf (Serf, SerfState(..), doJob, sStderr) @@ -173,8 +174,9 @@ acquireWorker act = mkRAcquire (async act) cancel pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e) => (Serf e, EventLog, SerfState) -> MVar () + -> MultiEyreApi -> RAcquire e () -pier (serf, log, ss) mStart = do +pier (serf, log, ss) mStart multi = do computeQ <- newTQueueIO persistQ <- newTQueueIO executeQ <- newTQueueIO @@ -222,7 +224,7 @@ pier (serf, log, ss) mStart = do -- add them. let showErr = atomically . Term.trace muxed . (flip append "\r\n") let (bootEvents, startDrivers) = - drivers inst ship (isFake logId) + drivers inst multi ship (isFake logId) (writeTQueue computeQ) shutdownEvent (Term.TSize{tsWide=80, tsTall=24}, muxed) @@ -283,18 +285,23 @@ data Drivers e = Drivers , dTerm :: EffCb e TermEf } -drivers :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e) - => KingId -> Ship -> Bool -> (Ev -> STM ()) - -> STM() - -> (Term.TSize, Term.Client) - -> (Text -> RIO e ()) - -> ([Ev], RAcquire e (Drivers e)) -drivers inst who isFake plan shutdownSTM termSys stderr = +drivers + :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e) + => KingId + -> MultiEyreApi + -> Ship + -> Bool + -> (Ev -> STM ()) + -> STM () + -> (Term.TSize, Term.Client) + -> (Text -> RIO e ()) + -> ([Ev], RAcquire e (Drivers e)) +drivers inst multi who isFake plan shutdownSTM termSys stderr = (initialEvents, runDrivers) where (behnBorn, runBehn) = behn inst plan (amesBorn, runAmes) = ames inst who isFake plan stderr - (httpBorn, runHttp) = eyre inst (error "TODO") who plan isFake + (httpBorn, runHttp) = eyre inst multi who plan isFake (clayBorn, runClay) = clay inst plan (irisBorn, runIris) = client inst plan (termBorn, runTerm) = Term.term termSys shutdownSTM inst plan