From: Michael Orlitzky Date: Fri, 20 Dec 2013 23:36:15 +0000 (-0500) Subject: Ad rudimentary hslogger logging. X-Git-Tag: 0.0.2~32 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=49c23c133221c9686dde0d52d06904db8d048724;p=dead%2Fhtsn.git Ad rudimentary hslogger logging. --- diff --git a/src/Logging.hs b/src/Logging.hs new file mode 100644 index 0000000..d8f9ed4 --- /dev/null +++ b/src/Logging.hs @@ -0,0 +1,85 @@ +module Logging ( + init_logging, + log_debug, + log_error, + log_info, + log_warning ) +where + +import System.IO ( hPutStr, stderr, stdout ) +import System.Log ( LogRecord ) +import System.Log.Formatter ( LogFormatter ) +import System.Log.Logger ( + Priority ( DEBUG, ERROR, INFO, WARNING ), + debugM, + errorM, + infoM, + rootLoggerName, + setHandlers, + setLevel, + updateGlobalLogger, + warningM ) +import System.Log.Handler.Simple ( + GenericHandler(..), + streamHandler ) + +import Terminal ( hPutBlueStr, hPutRedStr ) + +log_debug :: String -> IO () +log_debug = debugM rootLoggerName + +log_error :: String -> IO () +log_error = errorM rootLoggerName + +log_info :: String -> IO () +log_info = infoM rootLoggerName + +log_warning :: String -> IO () +log_warning = warningM rootLoggerName + +-- | Debug messages output to the console don't get a prefix, since +-- they're used to dump the network chatter. +console_formatter :: LogRecord -> IO String +console_formatter (DEBUG, msg) = return $ msg ++ "\n" +console_formatter (prio, msg) = return $ (show prio) ++ ": " ++ msg ++ "\n" + + +warn_formatter :: LogFormatter a +warn_formatter _ x@(WARNING, _) _ = console_formatter x +warn_formatter _ x@(ERROR, _) _ = console_formatter x +warn_formatter _ _ _ = return "" + +info_formatter :: LogFormatter a +info_formatter _ x@(INFO, _) _ = console_formatter x +info_formatter _ _ _ = return "" + +debug_formatter :: LogFormatter a +debug_formatter _ x@(DEBUG, _) _ = console_formatter x +debug_formatter _ _ _ = return "" + + +init_logging :: IO () +init_logging = do + -- Set the root logger to DEBUG level so that it will *attempt* to + -- process every message. + updateGlobalLogger rootLoggerName (setLevel DEBUG) + + stdout_handler <- streamHandler stdout DEBUG + stderr_handler <- streamHandler stderr WARNING + + let debug_handler = stdout_handler { formatter = debug_formatter, + writeFunc = hPutStr } + + let info_handler = stdout_handler { formatter = info_formatter, + priority = INFO, + writeFunc = hPutBlueStr } + + -- This also catches ERRORs. + let warn_handler = stderr_handler { formatter = warn_formatter, + priority = WARNING, + writeFunc = hPutRedStr } + + -- Set debug, info, and warn handlers for the root log. + updateGlobalLogger + rootLoggerName + (setHandlers [debug_handler, info_handler, warn_handler]) diff --git a/src/Main.hs b/src/Main.hs index 1b7458f..12cd002 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -28,6 +28,7 @@ import System.IO ( stderr, stdout ) import System.IO.Error (catchIOError) +import System.Log.Logger ( getLogger, rootLoggerName, saveGlobalLogger ) import System.Timeout (timeout) import CommandLine (get_args) @@ -36,21 +37,27 @@ import ExitCodes ( exit_no_feed_hosts, exit_no_password, exit_no_username ) +import Logging ( + init_logging, + log_debug, + log_error, + log_info, + log_warning ) import qualified OptionalConfiguration as OC ( OptionalConfiguration(..), from_rc ) -import Terminal (putGreenLn, report_error) +import Terminal (putGreenLn) import TSN.FeedHosts (FeedHosts(..)) import TSN.Xml (parse_xmlfid, xml_prologue) --- | Receive a single line of text from a Handle, echoing it to stdout --- in the process. +-- | Receive a single line of text from a Handle, and send it to the +-- debug log. -- recv_line :: Handle -> IO String recv_line h = do line <- hGetLine h - putStrLn line + log_debug line return line @@ -65,13 +72,14 @@ save_document :: Configuration -> String -> IO () save_document cfg doc = case maybe_path of Nothing -> - report_error "ERROR: document missing XML_File_ID element." + log_error "Document missing XML_File_ID element." Just path -> do already_exists <- doesFileExist path when already_exists $ do - let msg = "WARNING: file " ++ path ++ " already exists. Overwriting." - report_error msg + let msg = "File " ++ path ++ " already exists, overwriting." + log_warning msg writeFile path doc + log_info $ "Wrote file: " ++ path ++ "." where xmlfid = fmap show (parse_xmlfid doc) filename = fmap (++ ".xml") xmlfid @@ -105,13 +113,13 @@ log_in cfg h = do prompt1 <- recv_prompt h if prompt1 /= username_prompt then - report_error "ERROR: didn't receive username prompt." + log_error "Didn't receive username prompt." else do send_line h (username cfg) prompt2 <- recv_prompt h if prompt2 /= password_prompt then - report_error "ERROR: didn't receive password prompt." + log_error "Didn't receive password prompt." else do send_line h (password cfg) _ <- recv_line h -- "The Sports Network" @@ -136,7 +144,7 @@ log_in cfg h = do connect_and_loop :: Configuration -> String -> IO () connect_and_loop cfg host = do - putStrLn $ "Connecting to " ++ host ++ "..." + log_info $ "Connecting to " ++ host ++ "..." bracket acquire_handle release_handle action return () where @@ -160,7 +168,7 @@ connect_and_loop cfg host = do -- login_worked <- timeout five_seconds $ log_in cfg h case login_worked of - Nothing -> putStrLn "Login timed out (5s)." + Nothing -> log_info "Login timed out (5s)." Just _ -> loop cfg h [] @@ -176,6 +184,10 @@ thread_sleep seconds = do -- | The entry point of the program. main :: IO () main = do + init_logging + root_logger <- getLogger rootLoggerName + saveGlobalLogger root_logger + rc_cfg <- OC.from_rc cmd_cfg <- get_args @@ -188,15 +200,15 @@ main = do -- fall back on the default list (which gets merged from a -- Configuration below). when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do - report_error "ERROR: no feed hosts supplied." + log_error "No feed hosts supplied." exitWith (ExitFailure exit_no_feed_hosts) when (isNothing (OC.password opt_config)) $ do - report_error "ERROR: no password supplied." + log_error "No password supplied." exitWith (ExitFailure exit_no_password) when (isNothing (OC.username opt_config)) $ do - report_error "ERROR: no username supplied." + log_error "No username supplied." exitWith (ExitFailure exit_no_username) -- Finally, update a default config with any options that have been @@ -222,6 +234,6 @@ main = do round_robin cfg feed_host_idx = do let hosts = get_feed_hosts $ feed_hosts cfg let host = hosts !! feed_host_idx - catchIOError (connect_and_loop cfg host) (report_error . show) + catchIOError (connect_and_loop cfg host) (log_error . show) thread_sleep 10 -- Wait 10s before attempting to reconnect. round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts) diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs index f636a17..de2e97d 100644 --- a/src/OptionalConfiguration.hs +++ b/src/OptionalConfiguration.hs @@ -26,7 +26,7 @@ import System.Directory (getHomeDirectory) import System.FilePath ( () ) import System.IO.Error (catchIOError) -import Terminal (report_error) +import Logging (log_error) import TSN.FeedHosts (FeedHosts(..)) @@ -101,7 +101,7 @@ from_rc = do -- not serve much purpose. It could also be a security risk (visible -- password) if the admin screws up. home <- catchIOError getHomeDirectory (\e -> do - report_error (show e) + log_error (show e) return "$(HOME)") let user_config_path = home ".htsnrc" cfg <- DC.load [ DC.Optional user_config_path ] diff --git a/src/Terminal.hs b/src/Terminal.hs index cd35bf0..7e88505 100644 --- a/src/Terminal.hs +++ b/src/Terminal.hs @@ -1,6 +1,7 @@ module Terminal ( - putGreenLn, - report_error) + hPutBlueStr, + hPutRedStr, + putGreenLn ) where import Control.Monad.IO.Class (MonadIO(..)) @@ -10,7 +11,7 @@ import System.Console.ANSI ( ColorIntensity( Vivid ), ConsoleLayer( Foreground ), setSGR ) -import System.IO ( Handle, hPutStrLn, stderr ) +import System.IO ( Handle, hPutStr ) -- | Perform a computation (anything in MonadIO) with the given -- graphics mode(s) enabled. Revert to the previous graphics mode @@ -32,14 +33,15 @@ with_color color = -- | Output the given line to the given handle, in red. The silly -- camelCase name is for consistency with e.g. hPutStrLn. -hPutRedLn :: Handle -> String -> IO () -hPutRedLn h = with_color Red . hPutStrLn h +hPutRedStr :: Handle -> String -> IO () +hPutRedStr h = with_color Red . hPutStr h --- | Output the given line to stdout. The silly camelCase name is for --- consistency with e.g. putStrLn. +-- | Output the given line to the given handle, in blue. The silly +-- camelCase name is for consistency with e.g. hPutStrLn. +hPutBlueStr :: Handle -> String -> IO () +hPutBlueStr h = with_color Blue . hPutStr h + +-- | Output the given line to stdout, in green. The silly camelCase +-- name is for consistency with e.g. putStrLn. putGreenLn :: String -> IO () putGreenLn = with_color Green . putStrLn - --- | Report an error (to stderr). -report_error :: String -> IO () -report_error = hPutRedLn stderr