mirror of
https://github.com/urbit/shrub.git
synced 2024-12-24 11:24:21 +03:00
king: Use same logger from all contexts.
This commit is contained in:
Benjamin Summers
parent
b749017564
commit
ba4b9e7fdf
@ -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
|
||||
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)
|
||||
|
||||
@ -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
|
||||
mainTid <- myThreadId
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -150,10 +150,11 @@ 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
|
||||
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,12 +177,19 @@ 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))
|
||||
|
||||
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
|
||||
. HasLogFunc 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")
|
||||
let ctx = ["EYRE", "HTTPS", "REQ"]
|
||||
|
||||
let
|
||||
app = \req resp -> do
|
||||
runRIO envir $ logTr ctx "Got request"
|
||||
who <- reqShip req
|
||||
runRIO envir $ logTrace $ displayShow ("EYRE", "HTTPS", "REQ", who)
|
||||
runRIO envir $ logTr ctx ("Parsed HOST", who)
|
||||
runAppl who (rcReq api who) (rcKil api who) req resp
|
||||
|
||||
io (W.runTLSSocket tls opts sok app)
|
||||
io (W.runTLSSocket tlsMany opts sok app)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user