Rework the output/logging so that the stdout/stderr display does not pass through hslogger.
Change the output colors.
Update the example config with new options.
# would need to place it in $HOME/.htsnrc. On Windows, it probably
# needs to go in %APPDATA%, or C:\Users\<username>\Application Data.
+
# The username used to connect to the feed.
#
# Default: none (required)
#
# username = "whoever"
+
# The password used to connect to the feed.
#
# Default: none (required)
#
# password = "whatever"
+
# By default, htsn will output the XML files to the current working
# directory. Often this is not desirable, and you would rather save
# them to a specific location. Specify it here.
#
# output-directory = "/var/lib/htsn"
+
# A list of hostnames that supply the feed.
#
# Default: ["feed1.sportsnetwork.com",
# "feed3.sportsnetwork.com"]
#
# feed-hosts = [ "hostname1", "hostname2", ... ]
+
+
+# Do you want to log to syslog? If so, the log_file option below will
+# be ignored. This will log to the event log on Windows.
+#
+# Default: True
+#
+# syslog = False
+
+
+# If syslog = False, which file should we use for a log? Can be either
+# a relative or absolute path. It will not be auto-rotated; use
+# something log logrotate for that.
+#
+# Default: htsn.log
+#
+# log_file = /var/log/htsn/htsn.log
+
+
+# How verbose should the logs be? Valid levels are,
+#
+# "INFO", "WARNING", "ERROR"
+#
+# (there are others, but we don't emit them.)
+#
+# Default: "INFO"
+#
+# log_level = "WARNING"
program,
summary,
typ,
+ typFile,
typDir )
-- This let's us get the version from Cabal.
my_summary = program_name ++ "-" ++ (showVersion version)
+-- | A description of the "log_file" option.
+log_file_help :: String
+log_file_help =
+ "If syslog == False, log to the given file."
+
+log_level_help :: String
+log_level_help =
+ "How verbose should the logs be? One of INFO, WARNING, ERROR."
+
-- | A description of the "password" option.
password_help :: String
password_help =
output_directory_help =
"Directory in which to output the XML files; must be writable"
+-- | A description of the "syslog" option.
+syslog_help :: String
+syslog_help =
+ "Enable (default) or disable logging to syslog."
+
-- | A description of the "username" option.
username_help :: String
username_help =
arg_spec :: OptionalConfiguration
arg_spec =
OptionalConfiguration {
+ log_file = def &= typFile &= help log_file_help,
+ log_level = def &= typ "LEVEL" &= help log_level_help,
password = def &= typ "PASSWORD" &= help password_help,
output_directory = def &= typDir &= help output_directory_help,
+ syslog = def &= typ "BOOL" &= help syslog_help,
username = def &= typ "USERNAME" &= help username_help,
feed_hosts = def &= typ "HOSTNAMES" }
&= program program_name
merge_optional )
where
-import System.Console.CmdArgs.Default (Default(..))
+import System.Console.CmdArgs.Default ( Default(..) )
+import System.Log ( Priority( INFO ) )
import qualified OptionalConfiguration as OC (OptionalConfiguration(..))
import TSN.FeedHosts (FeedHosts(..))
data Configuration =
Configuration {
feed_hosts :: FeedHosts,
+ log_file :: FilePath,
+ log_level :: Priority,
password :: String,
output_directory :: FilePath,
+ syslog :: Bool,
username :: String }
deriving (Show)
-- | A Configuration with all of its fields set to their default
-- values.
instance Default Configuration where
- def = Configuration def def "." def
+ def = Configuration def "htsn.log" INFO def "." True def
-- | Merge a Configuration with an OptionalConfiguration. This is more
merge_optional cfg opt_cfg =
Configuration
all_feed_hosts
+ (merge (log_file cfg) (OC.log_file opt_cfg))
+ (merge (log_level cfg) (OC.log_level opt_cfg))
(merge (password cfg) (OC.password opt_cfg))
(merge (output_directory cfg) (OC.output_directory opt_cfg))
+ (merge (syslog cfg) (OC.syslog opt_cfg))
(merge (username cfg) (OC.username opt_cfg))
where
merge :: a -> Maybe a -> a
log_warning )
where
-import System.IO ( hPutStr, stderr, stdout )
-import System.Log ( LogRecord )
-import System.Log.Formatter ( LogFormatter )
+import System.Log.Handler.Simple ( GenericHandler )
import System.Log.Logger (
- Priority ( DEBUG, ERROR, INFO, WARNING ),
+ Priority ( DEBUG, INFO ),
debugM,
errorM,
infoM,
setLevel,
updateGlobalLogger,
warningM )
-import System.Log.Handler.Simple (
- GenericHandler(..),
- streamHandler )
-
-import Terminal ( hPutBlueStr, hPutRedStr )
log_debug :: String -> IO ()
log_debug = debugM 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])
+init_logging :: Bool -> IO ()
+init_logging use_syslog = do
+ let max_level = if use_syslog then INFO else DEBUG
+ -- We need to specify the type here; otherwise, setHandlers won't
+ -- accept the empty list as an instance of [LogHandler a].
+ let no_handlers = [] :: [GenericHandler a]
+ -- Removes the default "echo to stdout" handler.
+ updateGlobalLogger rootLoggerName (setLevel max_level
+ . setHandlers no_handlers)
stderr,
stdout )
import System.IO.Error (catchIOError)
-import System.Log.Logger ( getLogger, rootLoggerName, saveGlobalLogger )
import System.Timeout (timeout)
import CommandLine (get_args)
import qualified OptionalConfiguration as OC (
OptionalConfiguration(..),
from_rc )
-import Terminal (putGreenLn)
+import Terminal (
+ display_debug,
+ display_error,
+ display_info,
+ display_sent,
+ display_warning )
import TSN.FeedHosts (FeedHosts(..))
import TSN.Xml (parse_xmlfid, xml_prologue)
+-- | Warning! This does not automatically append a newline. The output
+-- is displayed/logged as-is, for, you know, debug purposes.
+report_debug :: String -> IO ()
+report_debug s = do
+ display_debug s
+ log_debug s
+
+report_error :: String -> IO ()
+report_error s = do
+ display_error $ "ERROR: " ++ s
+ log_error s
+
+report_info :: String -> IO ()
+report_info s = do
+ display_info s
+ log_info s
+
+-- | Warning! This does not automatically append a newline.
+report_sent :: String -> IO ()
+report_sent s = do
+ display_sent s
+ log_debug s
+
+report_warning :: String -> IO ()
+report_warning s = do
+ display_warning $ "WARNING: " ++ s
+ log_warning s
+
+
-- | 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
- log_debug line
+ report_debug (line ++ "\n")
return line
save_document cfg doc =
case maybe_path of
Nothing ->
- log_error "Document missing XML_File_ID element."
+ report_error "Document missing XML_File_ID element."
Just path -> do
already_exists <- doesFileExist path
when already_exists $ do
let msg = "File " ++ path ++ " already exists, overwriting."
- log_warning msg
+ report_warning msg
writeFile path doc
- log_info $ "Wrote file: " ++ path ++ "."
+ report_info $ "Wrote file: " ++ path ++ "."
where
xmlfid = fmap show (parse_xmlfid doc)
filename = fmap (++ ".xml") xmlfid
-- of its lines into one big string.
let document = concat $ reverse buffer
save_document cfg document
- loop cfg h [line] -- empty the buffer before looping again
+ loop cfg h [line] -- Empty the buffer before looping again.
else
- -- append line to the head of the buffer and loop
+ -- Append line to the head of the buffer and loop.
loop cfg h (line : buffer)
prompt1 <- recv_prompt h
if prompt1 /= username_prompt then
- log_error "Didn't receive username prompt."
+ report_error "Didn't receive username prompt."
else do
send_line h (username cfg)
prompt2 <- recv_prompt h
if prompt2 /= password_prompt then
- log_error "Didn't receive password prompt."
+ report_error "Didn't receive password prompt."
else do
send_line h (password cfg)
_ <- recv_line h -- "The Sports Network"
send_line :: Handle -> String -> IO ()
send_line h' s = do
- hPutStr h' (s ++ "\r\n")
- putGreenLn s
+ let line = s ++ "\r\n"
+ hPutStr h' line
+ display_sent line
recv_chars :: Int -> Handle -> IO String
recv_chars n h' = do
s <- sequence [ hGetChar h' | _ <- [1..n] ]
- putStr s
+ report_debug s
return s
recv_prompt :: Handle -> IO String
recv_prompt = recv_chars 10
+
connect_and_loop :: Configuration -> String -> IO ()
connect_and_loop cfg host = do
- log_info $ "Connecting to " ++ host ++ "..."
+ report_info $ "Connecting to " ++ host ++ "..."
bracket acquire_handle release_handle action
return ()
where
--
login_worked <- timeout five_seconds $ log_in cfg h
case login_worked of
- Nothing -> log_info "Login timed out (5s)."
+ Nothing -> report_info "Login timed out (5s)."
Just _ -> loop cfg h []
-- | 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
-- prefering the command-line ones.
let opt_config = rc_cfg <> cmd_cfg
- -- This is necessary because if the user specifies an empty list of
+ -- Update a default config with any options that have been set in
+ -- either the config file or on the command-line. We initialize
+ -- logging before the missing parameter checks below so that we can
+ -- log the errors.
+ let cfg = (def :: Configuration) `merge_optional` opt_config
+ init_logging (syslog cfg)
+
+ -- Check the optional config for missing required options. This is
+ -- necessary because if the user specifies an empty list of
-- hostnames in e.g. the config file, we want to bail rather than
- -- fall back on the default list (which gets merged from a
- -- Configuration below).
+ -- fall back on the default list (which was merged from a default
+ -- Configuration above).
when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do
- log_error "No feed hosts supplied."
+ report_error "No feed hosts supplied."
exitWith (ExitFailure exit_no_feed_hosts)
when (isNothing (OC.password opt_config)) $ do
- log_error "No password supplied."
+ report_error "No password supplied."
exitWith (ExitFailure exit_no_password)
when (isNothing (OC.username opt_config)) $ do
- log_error "No username supplied."
+ report_error "No username supplied."
exitWith (ExitFailure exit_no_username)
- -- Finally, update a default config with any options that have been
- -- set in either the config file or on the command-line.
- let cfg = (def :: Configuration) `merge_optional` opt_config
-
-- This may be superstition (and I believe stderr is unbuffered),
-- but it can't hurt.
hSetBuffering stderr NoBuffering
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) (log_error . show)
+ catchIOError (connect_and_loop cfg host) (report_error . show)
thread_sleep 10 -- Wait 10s before attempting to reconnect.
round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
-- | An OptionalConfiguration is just like a 'Configuration', except
-- all of its fields are optional. The user can set options in two
Worth(Optional),
load,
lookup )
-import Data.Data (Data)
-import Data.Maybe (fromMaybe)
-import Data.Monoid (Monoid(..))
-import Data.Typeable (Typeable)
-import System.Directory (getHomeDirectory)
+import qualified Data.Configurator.Types as DCT (
+ Configured,
+ Value( String ),
+ convert )
+import Data.Data ( Data )
+import Data.Maybe ( fromMaybe )
+import Data.Monoid ( Monoid(..) )
+import Data.Typeable ( Typeable )
+import System.Directory ( getHomeDirectory )
import System.FilePath ( (</>) )
-import System.IO.Error (catchIOError)
+import System.IO.Error ( catchIOError )
+import System.Log ( Priority(..) )
+import Logging ( log_error )
+import TSN.FeedHosts ( FeedHosts(..) )
-import Logging (log_error)
-import TSN.FeedHosts (FeedHosts(..))
+-- Derive standalone instances of Data and Typeable for Priority. This
+-- is necessary for OptionalConfiguration (which contains a Maybe
+-- Priority) to derive Data and Typeable.
+deriving instance Data Priority
+deriving instance Typeable Priority
-- | The same as Configuration, except everything is optional. It's easy to
-- merge two of these by simply dropping the Nothings in favor of
--
data OptionalConfiguration =
OptionalConfiguration {
- feed_hosts :: FeedHosts,
- password :: Maybe String,
+ feed_hosts :: FeedHosts,
+ log_file :: Maybe FilePath,
+ log_level :: Maybe Priority,
+ password :: Maybe String,
output_directory :: Maybe FilePath,
- username :: Maybe String }
+ syslog :: Maybe Bool,
+ username :: Maybe String }
deriving (Show, Data, Typeable)
Nothing
Nothing
Nothing
+ Nothing
+ Nothing
+ Nothing
-- | Combine @cfg1@ and @cfg2@, giving precedence to @cfg2@.
cfg1 `mappend` cfg2 =
OptionalConfiguration
all_feed_hosts
+ (merge (log_file cfg1) (log_file cfg2))
+ (merge (log_level cfg1) (log_level cfg2))
(merge (password cfg1) (password cfg2))
(merge (output_directory cfg1) (output_directory cfg2))
+ (merge (syslog cfg1) (syslog cfg2))
(merge (username cfg1) (username cfg2))
where
merge :: (Maybe a) -> (Maybe a) -> (Maybe a)
else cfg2
+instance DCT.Configured Priority where
+ -- | This allows us to read a Priority level out of a Configurator
+ -- config file. By default Configurator wouldn't know what to do,
+ -- so we have to tell it that we expect one of the valid Priority
+ -- constructors.
+ convert (DCT.String "INFO") = Just INFO
+ convert (DCT.String "WARNING") = Just WARNING
+ convert (DCT.String "ERROR") = Just ERROR
+ convert _ = Nothing
+
+
-- | Obtain an OptionalConfiguration from the file ".htsnrc" in the
-- user's home directory.
--
return "$(HOME)")
let user_config_path = home </> ".htsnrc"
cfg <- DC.load [ DC.Optional user_config_path ]
+ cfg_log_file <- DC.lookup cfg "log_file"
+ cfg_log_level <- DC.lookup cfg "log_level"
cfg_password <- DC.lookup cfg "password"
cfg_output_directory <- DC.lookup cfg "output_directory"
+ cfg_syslog <- DC.lookup cfg "syslog"
cfg_username <- DC.lookup cfg "username"
cfg_feed_hosts <- DC.lookup cfg "feed_hosts"
return $ OptionalConfiguration
(fromMaybe (FeedHosts []) cfg_feed_hosts)
+ cfg_log_file
+ cfg_log_level
cfg_password
cfg_output_directory
+ cfg_syslog
cfg_username
-- DC is needed only for the DCT.Configured instance of String.
import qualified Data.Configurator as DC()
-import qualified Data.Configurator.Types as DCT
+import qualified Data.Configurator.Types as DCT (
+ Configured,
+ Value( List ),
+ convert )
import Data.Data (Data)
import System.Console.CmdArgs.Default (Default(..))
import Data.Typeable (Typeable)
module Terminal (
- hPutBlueStr,
- hPutRedStr,
- putGreenLn )
+ display_debug,
+ display_error,
+ display_info,
+ display_sent,
+ display_warning )
where
import Control.Monad.IO.Class (MonadIO(..))
Color(..),
ColorIntensity( Vivid ),
ConsoleLayer( Foreground ),
- setSGR )
-import System.IO ( Handle, hPutStr )
+ hSetSGR )
+import System.IO ( Handle, hPutStr, stderr, stdout )
-- | Perform a computation (anything in MonadIO) with the given
-- graphics mode(s) enabled. Revert to the previous graphics mode
-- after the computation has finished.
-with_sgr :: (MonadIO m) => [SGR] -> m a -> m a
-with_sgr sgrs computation = do
- liftIO $ setSGR sgrs
+with_sgr :: (MonadIO m) => Handle -> [SGR] -> m a -> m a
+with_sgr h sgrs computation = do
+ liftIO $ hSetSGR h sgrs
x <- computation
- liftIO $ setSGR []
+ liftIO $ hSetSGR h []
return x
--- | Perform a computation (anything in MonadIO) with the terminal
--- output set to a certain color. Reset to the default color after
--- the computation has finished.
-with_color :: (MonadIO m) => Color -> m a -> m a
-with_color color =
- with_sgr [SetColor Foreground Vivid color]
+-- | Perform a computation (anything in MonadIO) with the output set
+-- to a certain color. Reset to the default color after the
+-- computation has finished.
+with_color :: (MonadIO m) => Handle -> Color -> m a -> m a
+with_color h color =
+ with_sgr h [SetColor Foreground Vivid color]
--- | Output the given line to the given handle, in red. The silly
--- camelCase name is for consistency with e.g. hPutStrLn.
-hPutRedStr :: Handle -> String -> IO ()
-hPutRedStr h = with_color Red . hPutStr h
+hPutStrColor :: Handle -> Color -> String -> IO ()
+hPutStrColor h c = with_color h c . hPutStr h
--- | 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
+hPutStrColorLn :: Handle -> Color -> String -> IO ()
+hPutStrColorLn h c s = hPutStrColor h c (s ++ "\n")
--- | 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
+-- | Don't automatically append a newline.
+display_sent :: String -> IO ()
+display_sent = hPutStrColor stdout Green
+
+display_debug :: String -> IO ()
+display_debug = putStr
+
+display_info :: String -> IO ()
+display_info = hPutStrColorLn stdout Cyan
+
+display_warning :: String -> IO ()
+display_warning = hPutStrColorLn stderr Yellow
+
+display_error :: String -> IO ()
+display_error = hPutStrColorLn stderr Red
projects / dead / htsn.git / commitdiff