Ad rudimentary hslogger logging.

[dead/htsn.git] / src / Main.hs

diff --git a/src/Main.hs b/src/Main.hs
index 1b7458fe880c83463038abbc2de73be16f3d09ff..12cd00268bf60444faf2d7449dd2cd5ed4866a3f 100644 (file)
--- 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)