X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=38dd2e5ad5e8af5c4336c667507a6a87b74c0ccd;hb=bb74b494c23a737b9c0355148d25f090545b856b;hp=f2febcb95ced479f1b965e2ea96ef21bf4ab7326;hpb=eb1187607a616b36bb446650dc141019345eed8f;p=dead%2Fhtsn.git

diff --git a/src/Main.hs b/src/Main.hs
index f2febcb..38dd2e5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,7 +5,7 @@ module Main
 where
 
 import Control.Concurrent ( threadDelay )
-import Control.Exception.Base ( bracket )
+import Control.Exception ( bracket, throw )
 import Control.Monad ( when )
 import Data.List ( isPrefixOf )
 import Data.Maybe ( isNothing )
@@ -35,53 +35,21 @@ import Configuration ( Configuration(..), merge_optional )
 import ExitCodes (
   exit_no_feed_hosts,
   exit_no_password,
-  exit_no_username )
-import Logging (
-  init_logging,
-  log_debug,
-  log_error,
-  log_info,
-  log_warning )
+  exit_no_username,
+  exit_pidfile_exists )
+import FeedHosts ( FeedHosts(..) )
+import Network.Services.TSN.Logging ( init_logging )
 import qualified OptionalConfiguration as OC (
   OptionalConfiguration(..),
   from_rc )
-import Terminal (
-  display_debug,
-  display_error,
-  display_info,
-  display_sent,
-  display_warning )
-import TSN.FeedHosts ( FeedHosts(..) )
-import TSN.Xml ( parse_xmlfid )
-
-
--- | 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
+import Network.Services.TSN.Report (
+  report_debug,
+  report_info,
+  report_warning,
+  report_error )
+import Network.Services.TSN.Terminal ( display_sent )
+import Xml ( parse_xmlfid )
+import Unix ( full_daemonize )
 
 
 -- | Receive a single line of text from a Handle, and send it to the
@@ -103,10 +71,9 @@ recv_line h = do
 --
 save_document :: Configuration -> String -> IO ()
 save_document cfg doc =
-  case maybe_path of
-    Nothing ->
-      report_error "Document missing XML_File_ID element."
-    Just path -> do
+  case either_path of
+    Left err -> report_error err
+    Right path -> do
       already_exists <- doesFileExist path
       when already_exists $ do
         let msg = "File " ++ path ++ " already exists, overwriting."
@@ -114,9 +81,10 @@ save_document cfg doc =
       writeFile path doc
       report_info $ "Wrote file: " ++ path ++ "."
   where
+    -- All the fmaps are because we're working inside a Maybe.
     xmlfid = fmap show (parse_xmlfid doc)
     filename = fmap (++ ".xml") xmlfid
-    maybe_path = fmap ((output_directory cfg) </>) filename
+    either_path = fmap ((output_directory cfg) </>) filename
 
 
 -- | Loop forever, writing the buffer to file whenever a </message>
@@ -151,6 +119,29 @@ loop !cfg !h !buffer = do
     loop cfg h new_buffer
 
 
+-- | Once we're connected to a feed, we need to log in. There's no
+--   protocol for this (the docs don't mention one), but we have
+--   (apparently) successfully guessed it.
+--
+--   The first thing TSN sends once we've connected is the string
+--   "Username: ", containing 10 ASCII characters. We then send a
+--   username, followed by a newline. If TSN likes the username, the
+--   second they'll send is the string "Password: ", also containing
+--   10 ASCII characters, to which we reply in kind.
+--
+--   Assuming the above will always hold, it is implemented as follows:
+--
+--     1. Receive 10 chars
+--
+--     2. Send username if we got the username prompt
+--
+--     3. Receive 10 chars
+--
+--     4. Send password if we got the password prompt
+--
+--   If TSN likes the password as well, they send the string "The
+--   Sports Network" before finally beginning to stream the feed.
+--
 log_in :: Configuration -> Handle -> IO ()
 log_in cfg h = do
   prompt1 <- recv_prompt h
@@ -158,24 +149,26 @@ log_in cfg h = do
   if prompt1 /= username_prompt then
     report_error "Didn't receive username prompt."
   else do
-    send_line h (username cfg)
+    send_cred h (username cfg)
     prompt2 <- recv_prompt h
 
     if prompt2 /= password_prompt then
       report_error "Didn't receive password prompt."
     else do
-      send_line h (password cfg)
+      send_cred h (password cfg)
       _ <- recv_line h -- "The Sports Network"
+      report_info $ "Logged in as " ++ (username cfg) ++ "."
       return ()
   where
     username_prompt = "Username: "
     password_prompt = "Password: "
 
-    send_line :: Handle -> String -> IO ()
-    send_line h' s = do
+    send_cred :: Handle -> String -> IO ()
+    send_cred h' s = do
+      -- The carriage return is super important!
       let line = s ++ "\r\n"
       hPutStr h' line
-      display_sent line
+      display_sent line -- Don't log the username/password!
 
     recv_chars :: Int -> Handle -> IO String
     recv_chars n h' = do
@@ -187,9 +180,23 @@ log_in cfg h = do
     recv_prompt = recv_chars 10
 
 
-connect_and_loop :: Configuration -> String -> IO ()
-connect_and_loop cfg host = do
-  report_info $ "Connecting to " ++ host ++ "..."
+-- | Connect to @host@ and attempt to parse the feed. As long as we
+--   stay connected and nothing bad happens, the program will remain in
+--   this function. If anything goes wrong, then the current invocation
+--   of connect_and_parse will return, and get called again later
+--   (probably with a different @host@).
+--
+--  Steps:
+--
+--    1. Connect to the host on the XML port
+--
+--    2. Log in
+--
+--    3. Go into the eternal read/save loop.
+--
+connect_and_parse :: Configuration -> String -> IO ()
+connect_and_parse cfg host = do
+  report_info $ "Connecting to " ++ host ++ "."
   bracket acquire_handle release_handle action
   return ()
   where
@@ -219,7 +226,8 @@ connect_and_loop cfg host = do
       --
       login_worked <- timeout five_seconds $ log_in cfg h
       case login_worked of
-        Nothing -> report_info "Login timed out (5s)."
+        Nothing -> report_info $ "Login timed out (5 seconds). "
+                                   ++ "Waiting 5 seconds to reconnect."
         Just _ ->  loop cfg h []
 
 
@@ -233,6 +241,7 @@ thread_sleep seconds = do
 
 
 -- | The entry point of the program.
+--
 main :: IO ()
 main = do
   rc_cfg <- OC.from_rc
@@ -247,7 +256,7 @@ main = do
   -- 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)
+  init_logging (log_level cfg) (log_file cfg) (syslog cfg)
 
   -- Check the optional config for missing required options. This is
   -- necessary because if the user specifies an empty list of
@@ -266,13 +275,29 @@ main = do
     report_error "No username supplied."
     exitWith (ExitFailure exit_no_username)
 
+  when (daemonize cfg) $ do
+    -- Old PID files can be left around after an unclean shutdown. We
+    -- only care if we're running as a daemon.
+    pidfile_exists <- doesFileExist (pidfile cfg)
+    when pidfile_exists $ do
+      report_error $ "PID file " ++ (pidfile cfg) ++ " already exists. "
+                       ++ "Refusing to start."
+      exitWith (ExitFailure exit_pidfile_exists)
+
   -- This may be superstition (and I believe stderr is unbuffered),
   -- but it can't hurt.
   hSetBuffering stderr NoBuffering
   hSetBuffering stdout NoBuffering
 
-  -- Begin connecting to our feed hosts, starting with the first one.
-  round_robin cfg 0
+  -- The rest of the program is kicked off by the following line which
+  -- begins connecting to our feed hosts, starting with the first one,
+  -- and proceeds in a round-robin fashion.
+  let run_program = round_robin cfg 0
+
+  -- If we were asked to daemonize, do that; otherwise just run the thing.
+  if (daemonize cfg)
+  then try_daemonize cfg run_program
+  else run_program
 
   where
     -- | This is the top-level "loop forever" function. If an
@@ -285,6 +310,19 @@ 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_parse cfg host) (report_error . show)
       thread_sleep 5 -- Wait 5s before attempting to reconnect.
       round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)
+
+
+    -- | A exception handler around full_daemonize. If full_daemonize
+    --   doesn't work, we report the error and crash. This is fine; we
+    --   only need the program to be resilient once it actually starts.
+    --
+    try_daemonize :: Configuration -> IO () -> IO ()
+    try_daemonize cfg program =
+      catchIOError
+        (full_daemonize cfg program)
+        (\e -> do
+          report_error (show e)
+          throw e)