From ba4b9e7fdfb86b8cff4bdd37575a5379967b7ea0 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 13 May 2020 11:29:50 -0700 Subject: [PATCH] king: Use same logger from all contexts. --- pkg/hs/urbit-king/lib/Urbit/King/App.hs | 46 ++----- pkg/hs/urbit-king/lib/Urbit/King/Main.hs | 116 ++++++++++-------- pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs | 54 +++++--- 3 files changed, 113 insertions(+), 103 deletions(-) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index edef869b59..0eda0b41fc 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -3,7 +3,7 @@ -} module Urbit.King.App ( App - , runApp + , runAppStderr , runAppLogFile , runAppNoLog , runPierApp @@ -39,8 +39,8 @@ instance HasLogFunc App where instance HasStderrLogFunc App where stderrLogFuncL = appStderrLogFunc -runApp :: RIO App a -> IO a -runApp inner = do +runAppStderr :: RIO App a -> IO a +runAppStderr inner = do logOptions <- logOptionsHandle stderr True <&> setLogUseTime True <&> setLogUseLoc False @@ -105,36 +105,14 @@ instance HasNetworkConfig PierApp where instance HasConfigDir PierApp where configDirL = pierAppPierConfig . pcPierPath -runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a -runPierApp pierConfig networkConfig daemon inner = - if daemon - then execStderr - else withLogFileHandle execFile - where - execStderr = do - logOptions <- logOptionsHandle stderr True - <&> setLogUseTime True - <&> setLogUseLoc False +runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> RIO App a +runPierApp pierConfig networkConfig action = do + app <- ask - withLogFunc logOptions $ \logFunc -> - go $ PierApp { _pierAppLogFunc = logFunc - , _pierAppStderrLogFunc = logFunc - , _pierAppPierConfig = pierConfig - , _pierAppNetworkConfig = networkConfig - } + let pierApp = PierApp { _pierAppLogFunc = app ^. logFuncL + , _pierAppStderrLogFunc = app ^. stderrLogFuncL + , _pierAppPierConfig = pierConfig + , _pierAppNetworkConfig = networkConfig + } - execFile logHandle = do - logOptions <- logOptionsHandle logHandle True - <&> setLogUseTime True - <&> setLogUseLoc False - logStderrOptions <- logOptionsHandle stderr True - <&> setLogUseTime False - <&> setLogUseLoc False - withLogFunc logStderrOptions $ \logStderr -> - withLogFunc logOptions $ \logFunc -> - go $ PierApp { _pierAppLogFunc = logFunc - , _pierAppStderrLogFunc = logStderr - , _pierAppPierConfig = pierConfig - , _pierAppNetworkConfig = networkConfig - } - go app = runRIO app inner + io (runRIO pierApp action) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index e65d831e01..da58fb7cd4 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -92,7 +92,7 @@ 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 (runAppLogFile, runAppStderr, runPierApp) import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..)) import Urbit.Noun.Conversions (cordToUW) import Urbit.Time (Wen) @@ -437,14 +437,22 @@ pillFrom (CLI.PillSourceURL url) = do noun <- cueBS body & either throwIO pure fromNounErr noun & either (throwIO . uncurry ParseErr) pure -newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e () -newShip new opts = do - multi <- multiEyre (MultiEyreConf Nothing Nothing True) -- TODO Hack - newShip' multi new opts +newShip :: CLI.New -> CLI.Opts -> RIO App () +newShip CLI.New{..} opts = do + {- + TODO XXX HACK -newShip' :: forall e. HasLogFunc e => MultiEyreApi -> CLI.New -> CLI.Opts -> RIO e () -newShip' multi CLI.New{..} opts - | CLI.BootComet <- nBootType = do + Because the "new ship" flow *may* automatically start the ship, + we need to create this, but it's not actually correct. + + The right solution is to separate out the "new ship" flow from the + "run ship" flow, and possibly sequence them from the outside if + that's really needed. + -} + multi <- multiEyre (MultiEyreConf Nothing Nothing True) + + case nBootType of + CLI.BootComet -> do pill <- pillFrom nPillSource putStrLn "boot: retrieving list of stars currently accepting comets" starList <- dawnCometList @@ -454,14 +462,14 @@ newShip' multi CLI.New{..} opts eny <- io $ Sys.randomIO let seed = mineComet (Set.fromList starList) eny putStrLn ("boot: found comet " ++ renderShip (sShip seed)) - bootFromSeed pill seed + bootFromSeed multi pill seed - | CLI.BootFake name <- nBootType = do + CLI.BootFake name -> do pill <- pillFrom nPillSource ship <- shipFrom name - runTryBootFromPill pill name ship (Fake ship) + runTryBootFromPill multi pill name ship (Fake ship) - | CLI.BootFromKeyfile keyFile <- nBootType = do + 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?" @@ -474,10 +482,10 @@ newShip' multi CLI.New{..} opts pill <- pillFrom nPillSource - bootFromSeed pill seed + bootFromSeed multi pill seed where - shipFrom :: Text -> RIO e Ship + shipFrom :: Text -> RIO App Ship shipFrom name = case Ob.parsePatp name of Left x -> error "Invalid ship name" Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p @@ -487,7 +495,7 @@ newShip' multi CLI.New{..} opts Just x -> x Nothing -> "./" <> unpack name - nameFromShip :: Ship -> RIO e Text + nameFromShip :: Ship -> RIO App Text nameFromShip s = name where nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s @@ -495,8 +503,8 @@ newShip' multi CLI.New{..} opts Nothing -> error "Urbit.ob didn't produce string with ~" Just x -> pure x - bootFromSeed :: Pill -> Seed -> RIO e () - bootFromSeed pill seed = do + bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO App () + bootFromSeed multi pill seed = do ethReturn <- dawnVent seed case ethReturn of @@ -504,23 +512,22 @@ newShip' multi CLI.New{..} opts Right dawn -> do let ship = sShip $ dSeed dawn name <- nameFromShip ship - runTryBootFromPill pill name ship (Dawn dawn) + runTryBootFromPill multi pill name ship (Dawn dawn) flags = toSerfFlags opts -- Now that we have all the information for running an application with a -- PierConfig, do so. - runTryBootFromPill pill name ship bootEvent = do + runTryBootFromPill multi pill name ship bootEvent = do let pierConfig = toPierConfig (pierPath name) opts let networkConfig = toNetworkConfig opts - io $ runPierApp pierConfig networkConfig True $ + runPierApp pierConfig networkConfig $ tryBootFromPill True pill nLite flags ship bootEvent multi ------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent - -runShip :: MonadIO m => CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> m () -runShip (CLI.Run pierPath) opts daemon multi = io $ do - tid <- myThreadId +runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO App () +runShip (CLI.Run pierPath) opts daemon multi = do + tid <- io myThreadId let onTermExit = throwTo tid UserInterrupt mStart <- newEmptyMVar if daemon @@ -528,11 +535,11 @@ runShip (CLI.Run pierPath) opts daemon multi = io $ do else do connectionThread <- async $ do readMVar mStart - finally (runAppNoLog $ connTerm pierPath) onTermExit + finally (connTerm pierPath) onTermExit finally (runPier mStart) (cancel connectionThread) where runPier mStart = - runPierApp pierConfig networkConfig daemon $ + runPierApp pierConfig networkConfig $ tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) @@ -582,27 +589,39 @@ checkComet = do main :: IO () main = do + args <- CLI.parseArgs + hSetBuffering stdout NoBuffering + setupSignalHandlers + + runApp args $ case args of + CLI.CmdRun ko ships -> runShips ko ships + CLI.CmdNew n o -> newShip n o + CLI.CmdBug (CLI.CollectAllFX pax ) -> collectAllFx pax + CLI.CmdBug (CLI.EventBrowser pax ) -> startBrowser pax + CLI.CmdBug (CLI.ValidatePill pax pil s) -> testPill pax pil s + CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l + CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l + CLI.CmdBug (CLI.ReplayEvents pax l ) -> replayPartEvs pax l + CLI.CmdBug (CLI.CheckDawn pax ) -> checkDawn pax + CLI.CmdBug CLI.CheckComet -> checkComet + CLI.CmdCon pier -> connTerm pier + + where + runApp args | willRunTerminal args = runAppLogFile + runApp args | otherwise = runAppStderr + + setupSignalHandlers = do mainTid <- myThreadId - - hSetBuffering stdout NoBuffering - let onKillSig = throwTo mainTid UserInterrupt + for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do + Sys.installHandler sig (Sys.Catch onKillSig) Nothing - Sys.installHandler Sys.sigTERM (Sys.Catch onKillSig) Nothing - Sys.installHandler Sys.sigINT (Sys.Catch onKillSig) Nothing - - CLI.parseArgs >>= \case - 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 - CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s - CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l - CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l - CLI.CmdBug (CLI.ReplayEvents pax l) -> runApp $ replayPartEvs pax l - CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax - CLI.CmdBug CLI.CheckComet -> runApp $ checkComet - CLI.CmdCon pier -> runAppLogFile $ connTerm pier + willRunTerminal :: CLI.Cmd -> Bool + willRunTerminal = \case + CLI.CmdCon _ -> True + CLI.CmdRun ko [(_,_,daemon)] -> not daemon + CLI.CmdRun ko _ -> False + _ -> False {- @@ -613,7 +632,7 @@ main = do TODO Use logging system instead of printing. -} -runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> IO () +runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO App () runShipRestarting waitForKillRequ r o multi = do let pier = pack (CLI.rPierPath r) loop = runShipRestarting waitForKillRequ r o multi @@ -663,8 +682,8 @@ runShips CLI.KingOpts {..} ships = do [(r, o, d)] -> runShip r o d me ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me -runMultipleShips :: MonadIO m => [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> m () -runMultipleShips ships multi = io $ do +runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO App () +runMultipleShips ships multi = do killSignal <- newEmptyTMVarIO let waitForKillRequ = readTMVar killSignal @@ -692,8 +711,7 @@ runMultipleShips ships multi = io $ do -------------------------------------------------------------------------------- connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e () -connTerm pier = - Term.runTerminalClient pier +connTerm = Term.runTerminalClient -------------------------------------------------------------------------------- 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 9fd6423957..a105befaed 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs @@ -149,11 +149,12 @@ openFreePort hos = do retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a retry act = act >>= \case Right res -> pure res - Left exn -> do - logError (displayShow ("EYRE", "Failed to open ports.", exn)) - logError (displayShow ("EYRE", "Waiting 250ms then trying again.")) - threadDelay 250_000 + Left exn -> do + logTr ctx ("Failed to open ports. Waiting 5s, then trying again.", exn) + threadDelay 5_000_000 retry act + where + ctx = ["EYRE", "SERV", "retry"] tryOpenChoices :: HasLogFunc e @@ -176,11 +177,18 @@ tryOpenChoices hos = go tryOpenAny :: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket)) tryOpenAny hos = do - logTrace (displayShow ("EYRE", "Asking the OS for any free port.")) + let ctx = ["EYRE", "SERV", "tryOpenAny"] + logTr ctx "Asking the OS for any free port." io (openFreePort hos) >>= \case - Left exn -> pure (Left exn) - Right (p,s) -> do - pure (Right (p,s)) + Left exn -> pure (Left exn) + Right (p, s) -> do + pure (Right (p, s)) + +logTr :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e () +logTr ctx msg = logTrace (prefix <> suffix) + where + prefix = display (concat $ fmap (<> ": ") ctx) + suffix = displayShow msg forceOpenSocket :: forall e @@ -193,11 +201,12 @@ forceOpenSocket hos por = mkRAcquire opn kil kil = io . Net.close . snd opn = do - logTrace (displayShow ("EYRE", "SERV", "forceOpenSocket", hos, por)) + let ctx = ["EYRE", "SERV", "forceOpenSocket"] + logTr ctx (hos, por) (p, s) <- retry $ case por of SPAnyPort -> tryOpenAny bind SPChoices ps -> tryOpenChoices bind ps - rio $ logTrace $ displayShow ("EYRE", "Opened port.", p) + logTr ctx ("Opened port.", p) pure (p, s) bind = case hos of @@ -221,14 +230,15 @@ onSniHdr :: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials onSniHdr env (MTC mtls) mHos = do tabl <- atomically (readTVar mtls) - runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", tabl, mHos) + runRIO env $ logTr ctx (tabl, mHos) ship <- hostShip (encodeUtf8 . pack <$> mHos) - runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", ship) + runRIO env $ logTr ctx ship tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd) - runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", tcfg) + runRIO env $ logTr ctx tcfg pure (Credentials [tcfg]) where notRunning ship = error ("Ship not running: ~" <> show ship) + ctx = ["EYRE", "HTTPS", "SNI"] startServer :: HasLogFunc e @@ -276,15 +286,19 @@ startServer typ hos por sok red vLive = do let sni = def { onServerNameIndication = onSniHdr envir mtls } - let tls = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey) { W.tlsServerHooks = sni } + let tlsSing = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey) + let tlsMany = tlsSing { W.tlsServerHooks = sni } - let app = \req resp -> do - runRIO envir $ logTrace $ displayShow ("EYRE", "HTTPS", "REQ") - who <- reqShip req - runRIO envir $ logTrace $ displayShow ("EYRE", "HTTPS", "REQ", who) - runAppl who (rcReq api who) (rcKil api who) req resp + let ctx = ["EYRE", "HTTPS", "REQ"] - io (W.runTLSSocket tls opts sok app) + let + app = \req resp -> do + runRIO envir $ logTr ctx "Got request" + who <- reqShip req + runRIO envir $ logTr ctx ("Parsed HOST", who) + runAppl who (rcReq api who) (rcKil api who) req resp + + io (W.runTLSSocket tlsMany opts sok app) --------------------------------------------------------------------------------