diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index cf17992380..224f67d7c2 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -91,6 +91,7 @@ import Control.Exception (AsyncException(UserInterrupt)) import Control.Lens ((&)) import System.Process (system) import Text.Show.Pretty (pPrint) +import Urbit.King.App (App) import Urbit.King.App (runApp, runAppLogFile, runAppNoLog, runPierApp) import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..)) import Urbit.Noun.Conversions (cordToUW) @@ -514,8 +515,8 @@ newShip' multi CLI.New{..} opts ------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent -runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> IO () -runShip (CLI.Run pierPath) opts daemon multi = do +runShip :: MonadIO m => CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> m () +runShip (CLI.Run pierPath) opts daemon multi = io $ do tid <- myThreadId let onTermExit = throwTo tid UserInterrupt mStart <- newEmptyMVar @@ -588,7 +589,7 @@ main = do Sys.installHandler Sys.sigINT (Sys.Catch onKillSig) Nothing CLI.parseArgs >>= \case - CLI.CmdRun ko ships -> runShips ko ships + CLI.CmdRun ko ships -> runApp $ runShips ko ships CLI.CmdNew n o -> runApp $ newShip n o CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax @@ -632,7 +633,7 @@ runShipRestarting waitForKillRequ r o multi = do putStrLn ("Ship terminated: " <> pier) -runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> IO () +runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO App () runShips CLI.KingOpts {..} ships = do let meConf = MultiEyreConf { mecHttpPort = fromIntegral <$> koSharedHttpPort @@ -650,7 +651,7 @@ runShips CLI.KingOpts {..} ships = do - In pier environment: pier path and config available. - In running ship environment: serf state, event queue available. -} - multi <- runApp (multiEyre meConf) + multi <- multiEyre meConf go multi ships where @@ -659,8 +660,8 @@ runShips CLI.KingOpts {..} ships = do [(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 +runMultipleShips :: MonadIO m => [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> m () +runMultipleShips ships multi = io $ do killSignal <- newEmptyTMVarIO let waitForKillRequ = readTMVar killSignal diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs index 4b2b34ba91..4eb65288ca 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs @@ -174,6 +174,8 @@ startServ startServ multi who isFake conf plan = do logTrace "startServ" + let vLive = meaLive multi + srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32) let mTls = hscSecure conf >>= parseTlsConfig @@ -191,8 +193,6 @@ startServ multi who isFake conf plan = do let soHost :: SockOpts -> ServHost soHost so = if soLocalhost so then SHLocalhost else SHAnyHostOk - vLive <- newTVarIO emptyLiveReqs - let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM () onReq which _ship reqId reqInfo = plan (requestEvent srvId which reqId reqInfo) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs index 8aca5ab726..a1d77aa445 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs @@ -33,6 +33,7 @@ data MultiEyreConf = MultiEyreConf , mecHttpPort :: Maybe Port , mecLocalhostOnly :: Bool } + deriving (Show) type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM () @@ -72,7 +73,9 @@ leaveMultiEyre MultiEyreApi {..} who = do modifyTVar' meaTlsC (deleteMap who) multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi -multiEyre conf@MultiEyreConf{..} = do +multiEyre conf@MultiEyreConf {..} = do + logTrace (displayShow ("EYRE", "MULTI", conf)) + vLive <- newTVarIO emptyLiveReqs vPlan <- newTVarIO mempty vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ())) @@ -94,25 +97,29 @@ multiEyre conf@MultiEyreConf{..} = do 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 - } - } + mIns <- for mecHttpPort $ \por -> do + logTrace (displayShow ("EYRE", "MULTI", "HTTP", 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 - } - } + mSec <- for mecHttpsPort $ \por -> do + logTrace (displayShow ("EYRE", "MULTI", "HTTPS", por)) + serv vLive $ ServConf + { scHost = host + , scPort = SPChoices $ singleton $ fromIntegral por + , scRedi = Nothing + , scType = STMultiHttps (MTC vTlsC) $ ReqApi + { rcReq = onReq Secure + , rcKil = onKil + } + } pure $ MultiEyreApi { meaLive = vLive diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs index 0b3cd2e25c..ea78833f99 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs @@ -21,7 +21,7 @@ module Urbit.Vere.Eyre.Serv ( ServApi(..) , TlsConfig(..) - , MultiTlsConfig + , MultiTlsConfig(..) , ReqApi(..) , ServType(..) , ServPort(..) @@ -61,27 +61,37 @@ data TlsConfig = TlsConfig , tcCerti :: ByteString , tcChain :: [ByteString] } + deriving (Show) -type MultiTlsConfig = TVar (Map Ship Credential) +newtype MultiTlsConfig = MTC (TVar (Map Ship Credential)) + +instance Show MultiTlsConfig where + show = const "MultiTlsConfig" data ReqApi = ReqApi { rcReq :: Ship -> Word64 -> E.ReqInfo -> STM () , rcKil :: Ship -> Word64 -> STM () } +instance Show ReqApi where + show = const "ReqApi" + data ServType = STHttp Ship ReqApi | STHttps Ship TlsConfig ReqApi | STMultiHttp ReqApi | STMultiHttps MultiTlsConfig ReqApi + deriving (Show) data ServPort = SPAnyPort | SPChoices (NonEmpty W.Port) + deriving (Show) data ServHost = SHLocalhost | SHAnyHostOk + deriving (Show) data ServConf = ServConf { scType :: ServType @@ -89,6 +99,7 @@ data ServConf = ServConf , scPort :: ServPort , scRedi :: Maybe W.Port } + deriving (Show) -- Opening Sockets ------------------------------------------------------------- @@ -179,6 +190,7 @@ forceOpenSocket hos por = mkRAcquire opn kil kil = io . Net.close . snd opn = do + logTrace (displayShow ("EYRE", "SERV", "forceOpenSocket", hos, por)) (p, s) <- retry $ case por of SPAnyPort -> tryOpenAny bind SPChoices ps -> tryOpenChoices bind ps @@ -202,8 +214,8 @@ hostShip (Just bs) = byteShip (hedLabel bs) & \case bytePatp = Ob.parsePatp . decodeUtf8Lenient hedLabel = fst . break (== fromIntegral (C.ord '.')) -onSniHdr :: TVar (Map Ship Credential) -> Maybe String -> IO Credentials -onSniHdr mtls mHos = do +onSniHdr :: MultiTlsConfig -> Maybe String -> IO Credentials +onSniHdr (MTC mtls) mHos = do ship <- hostShip (encodeUtf8 . pack <$> mHos) tabl <- atomically (readTVar mtls) tcfg <- lookup ship tabl & maybe (notRunning ship) pure @@ -271,14 +283,13 @@ configCreds TlsConfig {..} = Right rs -> Right rs serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi -serv vLive ServConf {..} = do +serv vLive conf@ServConf {..} = do + logTrace (displayShow ("EYRE", "SERV", "Start", conf)) kil <- newEmptyTMVarIO por <- newEmptyTMVarIO - void $ async $ do - tid <- async (runServ por) - atomically (takeTMVar kil) - cancel tid + tid <- async (runServ por) + _ <- async (atomically (takeTMVar kil) >> cancel tid) pure $ ServApi { saKil = void (tryPutTMVar kil ()) @@ -286,6 +297,7 @@ serv vLive ServConf {..} = do } where runServ vPort = do + logTrace (displayShow ("EYRE", "SERV", "runServ")) rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do atomically (putTMVar vPort por) startServer scType scHost por sok scRedi vLive diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs index 0e1c85f448..b45b94ac50 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs @@ -136,11 +136,6 @@ noHeader = do logError "Response block with no response header." error "Bad HttpEvent: Response block with no response header." -emptyChunk :: HasLogFunc e => RIO e a -emptyChunk = do - logError "Bad response action: empty chunk" - error "Bad response action: empty chunk" - dupHead :: HasLogFunc e => RIO e a dupHead = do logError "Multiple %head actions on one request" @@ -165,7 +160,7 @@ streamBlocks env init getAct = send init >> loop RADone -> pure () RABloc c -> send c >> loop - send "" = runRIO env emptyChunk + send "" = pure () send c = do runRIO env (logTrace (display ("sending chunk " <> tshow c))) yield $ Chunk $ fromByteString c