From 8ab60b913332defd310cc67a6165434f4562b0f0 Mon Sep 17 00:00:00 2001 From: pilfer-pandex <47340789+pilfer-pandex@users.noreply.github.com> Date: Fri, 14 Aug 2020 19:25:07 -0700 Subject: [PATCH 1/3] king: configure logging via cli flags --- pkg/hs/urbit-king/lib/Urbit/King/App.hs | 44 +++++---- pkg/hs/urbit-king/lib/Urbit/King/CLI.hs | 108 ++++++++++++++++++----- pkg/hs/urbit-king/lib/Urbit/King/Main.hs | 44 +++++---- 3 files changed, 139 insertions(+), 57 deletions(-) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index bd8b6b1a5..0cf1b07c6 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -25,13 +25,16 @@ where import Urbit.King.Config import Urbit.Prelude -import System.Directory (createDirectoryIfMissing, getHomeDirectory) +import System.Directory ( createDirectoryIfMissing + , getAppUserDataDirectory + ) import System.Posix.Internals (c_getpid) import System.Posix.Types (CPid(..)) import System.Random (randomIO) import Urbit.King.App.Class (HasStderrLogFunc(..)) + -- KingEnv --------------------------------------------------------------------- class HasKingId a where @@ -80,29 +83,34 @@ runKingEnvStderr verb inner = do 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 -> Maybe FilePath -> RIO KingEnv a -> IO a +runKingEnvLogFile verb 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 + stderrLogOptions <- + logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False - 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 <- getAppUserDataDirectory "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 diff --git a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs index b5edbcd2f..218412eea 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs @@ -6,21 +6,23 @@ -} 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 +data Host = Host + { hSharedHttpPort :: Maybe Word16 + , hSharedHttpsPort :: Maybe Word16 } deriving (Show) +-- | Options for each running pier. data Opts = Opts { oQuiet :: Bool , oHashless :: Bool @@ -44,6 +46,19 @@ data Opts = Opts } deriving (Show) +-- | Options for the logging subsystem. +data Log = Log + { lTarget :: Maybe (LogTarget FilePath) + , lLevel :: Maybe LogLevel + } + deriving (Show) + +data LogTarget a + = LogOff + | LogStderr + | LogFile a + deriving (Show) + data BootType = BootComet | BootFake Text @@ -102,8 +117,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) @@ -135,7 +150,7 @@ footNote exe = string $ intercalate "\n" -------------------------------------------------------------------------------- -parseArgs :: IO Cmd +parseArgs :: IO (Cmd, Log) parseArgs = do nm <- getProgName @@ -293,7 +308,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' @@ -332,22 +347,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 <- + optional + $ ( 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 (default)" + <> hidden + ) + <|> ( flag' LevelWarn + $ long "log-warn" + <> help "Log errors and warnings" + <> hidden + ) + <|> ( flag' LevelError + $ long "log-error" + <> help "Log errors only" + <> hidden + ) + + 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 - koSharedHttpPort <- +host :: Parser Host +host = do + hSharedHttpPort <- optional $ option auto $ metavar "PORT" @@ -355,7 +417,7 @@ kingOpts = do <> help "HTTP port" <> hidden - koSharedHttpsPort <- + hSharedHttpsPort <- optional $ option auto $ metavar "PORT" @@ -363,10 +425,10 @@ kingOpts = do <> help "HTTPS port" <> hidden - pure (KingOpts{..}) + pure (Host{..}) -runShip :: Parser Cmd -runShip = CmdRun <$> kingOpts <*> some runOneShip +runShip :: Parser (Cmd, Log) +runShip = (,) <$> (CmdRun <$> host <*> some runOneShip) <*> log valPill :: Parser Bug valPill = do @@ -410,8 +472,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) @@ -446,15 +508,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." diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index 2fb280d2d..e6e39650b 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -621,12 +621,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 @@ -640,11 +640,12 @@ main = do CLI.CmdCon pier -> connTerm pier where - runKingEnv args = + runKingEnv args log = let verb = verboseLogging args - in if willRunTerminal args - then runKingEnvLogFile verb - else runKingEnvStderr verb + in case logTarget (CLI.lTarget log) args of + CLI.LogFile f -> runKingEnvLogFile verb f + CLI.LogStderr -> runKingEnvStderr verb + CLI.LogOff -> runKingEnvNoLog setupSignalHandlers = do mainTid <- myThreadId @@ -657,12 +658,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 {- @@ -731,11 +743,11 @@ runShipNoRestart r o d multi = 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. } From 2d1f3cdfa06d899a1188e3b57621f3934fb05c0f Mon Sep 17 00:00:00 2001 From: pilfer-pandex <47340789+pilfer-pandex@users.noreply.github.com> Date: Sun, 16 Aug 2020 10:33:52 -0700 Subject: [PATCH 2/3] king: thread LogLevel through, make output better --- pkg/hs/urbit-king/lib/Urbit/King/App.hs | 23 ++++++++++++++++------- pkg/hs/urbit-king/lib/Urbit/King/CLI.hs | 10 +++++----- pkg/hs/urbit-king/lib/Urbit/King/Main.hs | 10 ++++++---- pkg/hs/urbit-king/lib/Urbit/Prelude.hs | 7 +++---- pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs | 4 ++-- 5 files changed, 32 insertions(+), 22 deletions(-) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index 0cf1b07c6..a4354d72e 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -76,23 +76,32 @@ 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 -> Maybe FilePath -> RIO KingEnv a -> IO a -runKingEnvLogFile verb fileM inner = do +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 + logOptionsHandle h verb + <&> setLogUseTime True + <&> setLogUseLoc False + <&> setLogMinLevel lvl stderrLogOptions <- - logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False + logOptionsHandle stderr verb + <&> setLogUseTime False + <&> setLogUseLoc False + <&> setLogMinLevel lvl withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions $ \logFunc -> runKingEnv logFunc stderrLogFunc inner diff --git a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs index 218412eea..283761e62 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs @@ -49,7 +49,7 @@ data Opts = Opts -- | Options for the logging subsystem. data Log = Log { lTarget :: Maybe (LogTarget FilePath) - , lLevel :: Maybe LogLevel + , lLevel :: LogLevel } deriving (Show) @@ -375,20 +375,19 @@ log = do ) lLevel <- - optional - $ ( flag' LevelDebug + ( 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 (default)" + <> help "Log errors, warnings, and info" <> hidden ) <|> ( flag' LevelWarn $ long "log-warn" - <> help "Log errors and warnings" + <> help "Log errors and warnings (default)" <> hidden ) <|> ( flag' LevelError @@ -396,6 +395,7 @@ log = do <> help "Log errors only" <> hidden ) + <|> pure LevelWarn pure (Log{..}) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index e6e39650b..998ca8f59 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -641,10 +641,12 @@ main = do where runKingEnv args log = - let verb = verboseLogging args - in case logTarget (CLI.lTarget log) args of - CLI.LogFile f -> runKingEnvLogFile verb f - CLI.LogStderr -> runKingEnvStderr verb + 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 diff --git a/pkg/hs/urbit-king/lib/Urbit/Prelude.hs b/pkg/hs/urbit-king/lib/Urbit/Prelude.hs index a19d44cc5..eee5cef16 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Prelude.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Prelude.hs @@ -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 diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index 78b6d9e5d..9e2ab32b3 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -494,7 +494,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 @@ -502,7 +502,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 From 6a236a2749c8306c64084289f26581d751e5ea13 Mon Sep 17 00:00:00 2001 From: pilfer-pandex <47340789+pilfer-pandex@users.noreply.github.com> Date: Mon, 17 Aug 2020 11:24:17 -0700 Subject: [PATCH 3/3] king: use XDG cache directory for default log location --- pkg/hs/urbit-king/lib/Urbit/King/App.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index a4354d72e..e5a1649af 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -26,7 +26,8 @@ import Urbit.King.Config import Urbit.Prelude import System.Directory ( createDirectoryIfMissing - , getAppUserDataDirectory + , getXdgDirectory + , XdgDirectory(XdgCache) ) import System.Posix.Internals (c_getpid) import System.Posix.Types (CPid(..)) @@ -83,7 +84,6 @@ runKingEnvStderr verb lvl inner = do <&> setLogUseTime True <&> setLogUseLoc False <&> setLogMinLevel lvl - withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a @@ -102,7 +102,6 @@ runKingEnvLogFile verb lvl fileM inner = do <&> setLogUseTime False <&> setLogUseLoc False <&> setLogMinLevel lvl - withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions $ \logFunc -> runKingEnv logFunc stderrLogFunc inner @@ -114,7 +113,7 @@ withLogFileHandle f act = defaultLogFile :: IO FilePath defaultLogFile = do - logDir <- getAppUserDataDirectory "urbit" + logDir <- getXdgDirectory XdgCache "urbit" createDirectoryIfMissing True logDir pure (logDir "king.log")