mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-14 17:41:33 +03:00
Merge pull request #3320 from urbit/pp/log-cli
king: configure logging via cli flags
This commit is contained in:
pilfer-pandex
GitHub
commit
7bf4ff4b00
@ -29,7 +29,10 @@ where
|
||||
import Urbit.King.Config
|
||||
import Urbit.Prelude
|
||||
|
||||
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
|
||||
import System.Directory ( createDirectoryIfMissing
|
||||
, getXdgDirectory
|
||||
, XdgDirectory(XdgCache)
|
||||
)
|
||||
import System.Posix.Internals (c_getpid)
|
||||
import System.Posix.Types (CPid(..))
|
||||
import System.Random (randomIO)
|
||||
@ -37,6 +40,7 @@ import Urbit.King.App.Class (HasStderrLogFunc(..))
|
||||
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
|
||||
import Urbit.Vere.Ports (PortControlApi, HasPortControlApi(..))
|
||||
|
||||
|
||||
-- KingEnv ---------------------------------------------------------------------
|
||||
|
||||
class HasKingId a where
|
||||
@ -77,36 +81,48 @@ instance HasKingId KingEnv where
|
||||
|
||||
-- Running KingEnvs ------------------------------------------------------------
|
||||
|
||||
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
|
||||
runKingEnvStderr verb inner = do
|
||||
runKingEnvStderr :: Bool -> LogLevel -> RIO KingEnv a -> IO a
|
||||
runKingEnvStderr verb lvl inner = do
|
||||
logOptions <-
|
||||
logOptionsHandle stderr verb <&> setLogUseTime True <&> setLogUseLoc False
|
||||
|
||||
logOptionsHandle stderr verb
|
||||
<&> setLogUseTime True
|
||||
<&> setLogUseLoc False
|
||||
<&> setLogMinLevel lvl
|
||||
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
|
||||
|
||||
runKingEnvLogFile :: Bool -> RIO KingEnv a -> IO a
|
||||
runKingEnvLogFile verb inner = withLogFileHandle $ \h -> do
|
||||
logOptions <-
|
||||
logOptionsHandle h verb <&> setLogUseTime True <&> setLogUseLoc False
|
||||
stderrLogOptions <-
|
||||
logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False
|
||||
runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a
|
||||
runKingEnvLogFile verb lvl fileM inner = do
|
||||
logFile <- case fileM of
|
||||
Just f -> pure f
|
||||
Nothing -> defaultLogFile
|
||||
withLogFileHandle logFile $ \h -> do
|
||||
logOptions <-
|
||||
logOptionsHandle h verb
|
||||
<&> setLogUseTime True
|
||||
<&> setLogUseLoc False
|
||||
<&> setLogMinLevel lvl
|
||||
stderrLogOptions <-
|
||||
logOptionsHandle stderr verb
|
||||
<&> setLogUseTime False
|
||||
<&> setLogUseLoc False
|
||||
<&> setLogMinLevel lvl
|
||||
withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions
|
||||
$ \logFunc -> runKingEnv logFunc stderrLogFunc inner
|
||||
|
||||
withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions
|
||||
$ \logFunc -> runKingEnv logFunc stderrLogFunc inner
|
||||
|
||||
withLogFileHandle :: (Handle -> IO a) -> IO a
|
||||
withLogFileHandle act = do
|
||||
home <- getHomeDirectory
|
||||
let logDir = home </> ".urbit"
|
||||
createDirectoryIfMissing True logDir
|
||||
withFile (logDir </> "king.log") AppendMode $ \handle -> do
|
||||
withLogFileHandle :: FilePath -> (Handle -> IO a) -> IO a
|
||||
withLogFileHandle f act =
|
||||
withFile f AppendMode $ \handle -> do
|
||||
hSetBuffering handle LineBuffering
|
||||
act handle
|
||||
|
||||
defaultLogFile :: IO FilePath
|
||||
defaultLogFile = do
|
||||
logDir <- getXdgDirectory XdgCache "urbit"
|
||||
createDirectoryIfMissing True logDir
|
||||
pure (logDir </> "king.log")
|
||||
|
||||
runKingEnvNoLog :: RIO KingEnv a -> IO a
|
||||
runKingEnvNoLog act = withFile "/dev/null" AppendMode $ \handle -> do
|
||||
logOptions <- logOptionsHandle handle True
|
||||
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc act
|
||||
runKingEnvNoLog act = runKingEnv mempty mempty act
|
||||
|
||||
runKingEnv :: LogFunc -> LogFunc -> RIO KingEnv a -> IO a
|
||||
runKingEnv logFunc stderr action = do
|
||||
|
||||
@ -6,22 +6,24 @@
|
||||
-}
|
||||
module Urbit.King.CLI where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude hiding (log)
|
||||
import Options.Applicative
|
||||
import Options.Applicative.Help.Pretty
|
||||
|
||||
import Data.Word (Word16)
|
||||
import RIO (LogLevel(..))
|
||||
import System.Environment (getProgName)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data KingOpts = KingOpts
|
||||
{ koSharedHttpPort :: Maybe Word16
|
||||
, koSharedHttpsPort :: Maybe Word16
|
||||
, koUseNatPmp :: Bool
|
||||
data Host = Host
|
||||
{ hSharedHttpPort :: Maybe Word16
|
||||
, hSharedHttpsPort :: Maybe Word16
|
||||
, hUseNatPmp :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Options for each running pier.
|
||||
data Opts = Opts
|
||||
{ oQuiet :: Bool
|
||||
, oHashless :: Bool
|
||||
@ -45,6 +47,19 @@ data Opts = Opts
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Options for the logging subsystem.
|
||||
data Log = Log
|
||||
{ lTarget :: Maybe (LogTarget FilePath)
|
||||
, lLevel :: LogLevel
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data LogTarget a
|
||||
= LogOff
|
||||
| LogStderr
|
||||
| LogFile a
|
||||
deriving (Show)
|
||||
|
||||
data BootType
|
||||
= BootComet
|
||||
| BootFake Text
|
||||
@ -103,8 +118,8 @@ data Bug
|
||||
deriving (Show)
|
||||
|
||||
data Cmd
|
||||
= CmdNew New Opts
|
||||
| CmdRun KingOpts [(Run, Opts, Bool)]
|
||||
= CmdNew New Opts
|
||||
| CmdRun Host [(Run, Opts, Bool)]
|
||||
| CmdBug Bug
|
||||
| CmdCon FilePath
|
||||
deriving (Show)
|
||||
@ -136,7 +151,7 @@ footNote exe = string $ intercalate "\n"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
parseArgs :: IO Cmd
|
||||
parseArgs :: IO (Cmd, Log)
|
||||
parseArgs = do
|
||||
nm <- getProgName
|
||||
|
||||
@ -196,11 +211,6 @@ pillFromURL = PillSourceURL <$> strOption
|
||||
<> value defaultPillURL
|
||||
<> help "URL to pill file")
|
||||
|
||||
enableNat :: Parser Bool
|
||||
enableNat = not <$> switch
|
||||
( long "no-port-forwarding"
|
||||
<> help "Disable trying to ask the router to forward ames ports")
|
||||
|
||||
pierPath :: Parser FilePath
|
||||
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
|
||||
|
||||
@ -299,7 +309,7 @@ opts = do
|
||||
|
||||
oVerbose <- switch $ short 'v'
|
||||
<> long "verbose"
|
||||
<> help "Verbose"
|
||||
<> help "Puts the serf and king into verbose mode"
|
||||
<> hidden
|
||||
|
||||
oExit <- switch $ short 'x'
|
||||
@ -338,24 +348,69 @@ opts = do
|
||||
|
||||
oFullReplay <- switch
|
||||
$ long "full-log-replay"
|
||||
<> help "Ignores the snapshot and recomputes state from log"
|
||||
<> help "Ignores snapshot and recomputes state from event log"
|
||||
<> hidden
|
||||
|
||||
pure (Opts{..})
|
||||
|
||||
newShip :: Parser Cmd
|
||||
newShip = CmdNew <$> new <*> opts
|
||||
log :: Parser Log
|
||||
log = do
|
||||
lTarget <-
|
||||
optional
|
||||
$ ( flag' LogStderr
|
||||
$ long "log-to-stderr"
|
||||
<> long "stderr"
|
||||
<> help "Display logs on stderr"
|
||||
<> hidden
|
||||
)
|
||||
<|> ( fmap LogFile . strOption
|
||||
$ long "log-to"
|
||||
<> metavar "LOG_FILE"
|
||||
<> help "Append logs to the given file"
|
||||
<> hidden
|
||||
)
|
||||
<|> ( flag' LogOff
|
||||
$ long "no-logging"
|
||||
<> help "Disable logging entirely"
|
||||
<> hidden
|
||||
)
|
||||
|
||||
lLevel <-
|
||||
( flag' LevelDebug
|
||||
$ long "log-debug"
|
||||
<> help "Log errors, warnings, info, and debug messages"
|
||||
<> hidden
|
||||
)
|
||||
<|> ( flag' LevelInfo
|
||||
$ long "log-info"
|
||||
<> help "Log errors, warnings, and info"
|
||||
<> hidden
|
||||
)
|
||||
<|> ( flag' LevelWarn
|
||||
$ long "log-warn"
|
||||
<> help "Log errors and warnings (default)"
|
||||
<> hidden
|
||||
)
|
||||
<|> ( flag' LevelError
|
||||
$ long "log-error"
|
||||
<> help "Log errors only"
|
||||
<> hidden
|
||||
)
|
||||
<|> pure LevelWarn
|
||||
|
||||
pure (Log{..})
|
||||
|
||||
newShip :: Parser (Cmd, Log)
|
||||
newShip = (,) <$> (CmdNew <$> new <*> opts) <*> log
|
||||
|
||||
runOneShip :: Parser (Run, Opts, Bool)
|
||||
runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df
|
||||
where
|
||||
df = switch (short 'd' <> long "daemon" <> help "Daemon mode" <> hidden)
|
||||
|
||||
kingOpts :: Parser KingOpts
|
||||
kingOpts = do
|
||||
koUseNatPmp <- enableNat
|
||||
|
||||
koSharedHttpPort <-
|
||||
host :: Parser Host
|
||||
host = do
|
||||
hSharedHttpPort <-
|
||||
optional
|
||||
$ option auto
|
||||
$ metavar "PORT"
|
||||
@ -363,7 +418,7 @@ kingOpts = do
|
||||
<> help "HTTP port"
|
||||
<> hidden
|
||||
|
||||
koSharedHttpsPort <-
|
||||
hSharedHttpsPort <-
|
||||
optional
|
||||
$ option auto
|
||||
$ metavar "PORT"
|
||||
@ -371,10 +426,17 @@ kingOpts = do
|
||||
<> help "HTTPS port"
|
||||
<> hidden
|
||||
|
||||
pure (KingOpts{..})
|
||||
hUseNatPmp <-
|
||||
fmap not
|
||||
$ switch
|
||||
$ long "no-port-forwarding"
|
||||
<> help "Disable trying to ask the router to forward ames ports"
|
||||
<> hidden
|
||||
|
||||
runShip :: Parser Cmd
|
||||
runShip = CmdRun <$> kingOpts <*> some runOneShip
|
||||
pure (Host{..})
|
||||
|
||||
runShip :: Parser (Cmd, Log)
|
||||
runShip = (,) <$> (CmdRun <$> host <*> some runOneShip) <*> log
|
||||
|
||||
valPill :: Parser Bug
|
||||
valPill = do
|
||||
@ -418,8 +480,8 @@ browseEvs = EventBrowser <$> pierPath
|
||||
checkDawn :: Parser Bug
|
||||
checkDawn = CheckDawn <$> keyfilePath
|
||||
|
||||
bugCmd :: Parser Cmd
|
||||
bugCmd = fmap CmdBug
|
||||
bugCmd :: Parser (Cmd, Log)
|
||||
bugCmd = (flip (,) <$> log <*>) $ fmap CmdBug
|
||||
$ subparser
|
||||
$ command "validate-pill"
|
||||
( info (valPill <**> helper)
|
||||
@ -454,15 +516,15 @@ bugCmd = fmap CmdBug
|
||||
$ progDesc "Shows the list of stars accepting comets"
|
||||
)
|
||||
|
||||
conCmd :: Parser Cmd
|
||||
conCmd = CmdCon <$> pierPath
|
||||
conCmd :: Parser (Cmd, Log)
|
||||
conCmd = (,) <$> (CmdCon <$> pierPath) <*> log
|
||||
|
||||
allFx :: Parser Bug
|
||||
allFx = do
|
||||
bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
|
||||
pure CollectAllFX{..}
|
||||
|
||||
cmd :: Parser Cmd
|
||||
cmd :: Parser (Cmd, Log)
|
||||
cmd = subparser
|
||||
$ command "new" ( info (newShip <**> helper)
|
||||
$ progDesc "Boot a new ship."
|
||||
|
||||
@ -635,12 +635,12 @@ checkComet = do
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- CLI.parseArgs
|
||||
(args, log) <- CLI.parseArgs
|
||||
|
||||
hSetBuffering stdout NoBuffering
|
||||
setupSignalHandlers
|
||||
|
||||
runKingEnv args $ case args of
|
||||
runKingEnv args log $ case args of
|
||||
CLI.CmdRun ko ships -> runShips ko ships
|
||||
CLI.CmdNew n o -> newShip n o
|
||||
CLI.CmdBug (CLI.CollectAllFX pax ) -> collectAllFx pax
|
||||
@ -654,11 +654,14 @@ main = do
|
||||
CLI.CmdCon pier -> connTerm pier
|
||||
|
||||
where
|
||||
runKingEnv args =
|
||||
let verb = verboseLogging args
|
||||
in if willRunTerminal args
|
||||
then runKingEnvLogFile verb
|
||||
else runKingEnvStderr verb
|
||||
runKingEnv args log =
|
||||
let
|
||||
verb = verboseLogging args
|
||||
CLI.Log {..} = log
|
||||
in case logTarget lTarget args of
|
||||
CLI.LogFile f -> runKingEnvLogFile verb lLevel f
|
||||
CLI.LogStderr -> runKingEnvStderr verb lLevel
|
||||
CLI.LogOff -> runKingEnvNoLog
|
||||
|
||||
setupSignalHandlers = do
|
||||
mainTid <- myThreadId
|
||||
@ -671,12 +674,23 @@ main = do
|
||||
CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
|
||||
_ -> False
|
||||
|
||||
willRunTerminal :: CLI.Cmd -> Bool
|
||||
willRunTerminal = \case
|
||||
CLI.CmdCon _ -> True
|
||||
CLI.CmdRun ko [(_,_,daemon)] -> not daemon
|
||||
CLI.CmdRun ko _ -> False
|
||||
_ -> False
|
||||
-- If the user hasn't specified where to log, what we do depends on what
|
||||
-- command she has issued. Notably, the LogFile Nothing outcome means that
|
||||
-- runKingEnvLogFile should run an IO action to get the official app data
|
||||
-- directory and open a canonically named log file there.
|
||||
logTarget :: Maybe (CLI.LogTarget FilePath)
|
||||
-> CLI.Cmd
|
||||
-> CLI.LogTarget (Maybe FilePath)
|
||||
logTarget = \case
|
||||
Just (CLI.LogFile f) -> const $ CLI.LogFile (Just f)
|
||||
Just CLI.LogStderr -> const $ CLI.LogStderr
|
||||
Just CLI.LogOff -> const $ CLI.LogOff
|
||||
Nothing -> \case
|
||||
CLI.CmdCon _ -> CLI.LogFile Nothing
|
||||
CLI.CmdRun ko [(_,_,daemon)] | daemon -> CLI.LogStderr
|
||||
| otherwise -> CLI.LogFile Nothing
|
||||
CLI.CmdRun ko _ -> CLI.LogStderr
|
||||
_ -> CLI.LogStderr
|
||||
|
||||
|
||||
{-
|
||||
@ -746,18 +760,18 @@ runShipNoRestart r o d = do
|
||||
cancel tid
|
||||
logTrace $ display (pier <> " terminated.")
|
||||
|
||||
runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
|
||||
runShips CLI.KingOpts {..} ships = do
|
||||
runShips :: CLI.Host -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
|
||||
runShips CLI.Host {..} ships = do
|
||||
let meConf = MultiEyreConf
|
||||
{ mecHttpPort = fromIntegral <$> koSharedHttpPort
|
||||
, mecHttpsPort = fromIntegral <$> koSharedHttpsPort
|
||||
{ mecHttpPort = fromIntegral <$> hSharedHttpPort
|
||||
, mecHttpsPort = fromIntegral <$> hSharedHttpsPort
|
||||
, mecLocalhostOnly = False -- TODO Localhost-only needs to be
|
||||
-- a king-wide option.
|
||||
}
|
||||
|
||||
multi <- multiEyre meConf
|
||||
|
||||
ports <- buildPortHandler koUseNatPmp
|
||||
ports <- buildPortHandler hUseNatPmp
|
||||
|
||||
runHostEnv multi ports (go ships)
|
||||
where
|
||||
|
||||
@ -34,10 +34,9 @@ import Text.Show.Pretty (pPrint, ppShow)
|
||||
import RIO (RIO, runRIO)
|
||||
import RIO (Utf8Builder, display, displayShow)
|
||||
import RIO (threadDelay)
|
||||
|
||||
import RIO (HasLogFunc, LogFunc, logDebug, logError, logFuncL, logInfo,
|
||||
logOptionsHandle, logOther, logWarn, mkLogFunc, setLogUseLoc,
|
||||
setLogUseTime, withLogFunc)
|
||||
import RIO (HasLogFunc, LogFunc, LogLevel(..), logDebug, logError, logFuncL,
|
||||
logInfo, logOptionsHandle, logOther, logWarn, mkLogFunc,
|
||||
setLogMinLevel, setLogUseLoc, setLogUseTime, withLogFunc)
|
||||
|
||||
io :: MonadIO m => IO a -> m a
|
||||
io = liftIO
|
||||
|
||||
@ -501,7 +501,7 @@ router slog waitFx Drivers {..} = do
|
||||
|
||||
logEvent :: HasLogFunc e => Ev -> RIO e ()
|
||||
logEvent ev = do
|
||||
logTrace $ "<- " <> display (summarizeEvent ev)
|
||||
logInfo $ "<- " <> display (summarizeEvent ev)
|
||||
logDebug $ "[EVENT]\n" <> display pretty
|
||||
where
|
||||
pretty :: Text
|
||||
@ -509,7 +509,7 @@ logEvent ev = do
|
||||
|
||||
logEffect :: HasLogFunc e => Lenient Ef -> RIO e ()
|
||||
logEffect ef = do
|
||||
logTrace $ " -> " <> display (summarizeEffect ef)
|
||||
logInfo $ " -> " <> display (summarizeEffect ef)
|
||||
logDebug $ display $ "[EFFECT]\n" <> pretty ef
|
||||
where
|
||||
pretty :: Lenient Ef -> Text
|
||||
|
||||
Loading…
Reference in New Issue
Block a user