src/Main.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DoAndIfThenElse #-}
   3
   4 module Main
   5 where
   6
   7 import Control.Concurrent (threadDelay)
   8 import Control.Exception.Base (bracket)
   9 import Control.Monad (when)
  10 import Data.List (isPrefixOf)
  11 import Data.Maybe (isNothing)
  12 import Data.Monoid ((<>))
  13 import Network (
  14   connectTo,
  15   PortID (PortNumber) )
  16 import System.Console.CmdArgs (def)
  17 import System.Directory (doesFileExist)
  18 import System.Exit (ExitCode(..), exitWith)
  19 import System.FilePath ((</>))
  20 import System.IO (
  21   BufferMode (NoBuffering),
  22   Handle,
  23   hClose,
  24   hGetChar,
  25   hGetLine,
  26   hPutStr,
  27   hSetBuffering,
  28   stderr,
  29   stdout )
  30 import System.IO.Error (catchIOError)
  31 import System.Timeout (timeout)
  32
  33 import CommandLine (get_args)
  34 import Configuration (Configuration(..), merge_optional)
  35 import ExitCodes (
  36   exit_no_feed_hosts,
  37   exit_no_password,
  38   exit_no_username )
  39 import qualified OptionalConfiguration as OC (
  40   OptionalConfiguration(..),
  41   from_rc )
  42 import Terminal (putGreenLn, report_error)
  43 import TSN.FeedHosts (FeedHosts(..))
  44 import TSN.Xml (parse_xmlfid, xml_prologue)
  45
  46
  47 -- | Receive a single line of text from a Handle, echoing it to stdout
  48 --   in the process.
  49 --
  50 recv_line :: Handle -> IO String
  51 recv_line h = do
  52   line <- hGetLine h
  53   putStrLn line
  54   return line
  55
  56
  57 -- | Takes a Configuration, and an XML document (as a String). The XML
  58 --   document is written to the output directory, as specified by the
  59 --   Configuration.
  60 --
  61 --   This can fail, but we don't purposefully throw any exceptions. If
  62 --   something goes wrong, we would rather log it and keep going.
  63 --
  64 save_document :: Configuration -> String -> IO ()
  65 save_document cfg doc =
  66   case maybe_path of
  67     Nothing ->
  68       report_error "ERROR: document missing XML_File_ID element."
  69     Just path -> do
  70       already_exists <- doesFileExist path
  71       when already_exists $ do
  72         let msg = "WARNING: file " ++ path ++ " already exists. Overwriting."
  73         report_error msg
  74       writeFile path doc
  75   where
  76     xmlfid = fmap show (parse_xmlfid doc)
  77     filename = fmap (++ ".xml") xmlfid
  78     maybe_path = fmap ((output_directory cfg) </>) filename
  79
  80
  81 -- | Loop forever, writing the buffer to file whenever a new XML
  82 --   prologue is seen. This is the low-level "loop forever" function
  83 --   that we stay in as long as we are connected to one feed.
  84 --
  85 loop :: Configuration -> Handle -> [String] -> IO ()
  86 loop !cfg !h !buffer = do
  87   line <- recv_line h
  88
  89   if (xml_prologue `isPrefixOf` line && not (null buffer))
  90   then do
  91     -- This is the beginning of a new document, and we have an "old"
  92     -- one to save. The buffer is in reverse (newest first) order,
  93     -- though, so we have to reverse it first. We then concatenate all
  94     -- of its lines into one big string.
  95     let document = concat $ reverse buffer
  96     save_document cfg document
  97     loop cfg h [line] -- empty the buffer before looping again
  98   else
  99     -- append line to the head of the buffer and loop
 100     loop cfg h (line : buffer)
 101
 102
 103 log_in :: Configuration -> Handle -> IO ()
 104 log_in cfg h = do
 105   prompt1 <- recv_prompt h
 106
 107   if prompt1 /= username_prompt then
 108     report_error "ERROR: didn't receive username prompt."
 109   else do
 110     send_line h (username cfg)
 111     prompt2 <- recv_prompt h
 112
 113     if prompt2 /= password_prompt then
 114       report_error "ERROR: didn't receive password prompt."
 115     else do
 116       send_line h (password cfg)
 117       _ <- recv_line h -- "The Sports Network"
 118       return ()
 119   where
 120     username_prompt = "Username: "
 121     password_prompt = "Password: "
 122
 123     send_line :: Handle -> String -> IO ()
 124     send_line h' s = do
 125       hPutStr h' (s ++ "\r\n")
 126       putGreenLn s
 127
 128     recv_chars :: Int -> Handle -> IO String
 129     recv_chars n h' = do
 130       s <- sequence [ hGetChar h' | _ <- [1..n] ]
 131       putStr s
 132       return s
 133
 134     recv_prompt :: Handle -> IO String
 135     recv_prompt = recv_chars 10
 136
 137 connect_and_loop :: Configuration -> String -> IO ()
 138 connect_and_loop cfg host = do
 139   putStrLn $ "Connecting to " ++ host ++ "..."
 140   bracket acquire_handle release_handle action
 141   return ()
 142   where
 143     five_seconds :: Int
 144     five_seconds = 5000000
 145
 146     acquire_handle = connectTo host (PortNumber 4500)
 147     release_handle = hClose
 148     action h = do
 149       -- No buffering anywhere.
 150       hSetBuffering h NoBuffering
 151
 152       -- The feed is often unresponsive after we send out username. It
 153       -- happens in a telnet session, too (albeit less frequently?),
 154       -- so there might be a bug on their end.
 155       --
 156       -- If we dump the packets with tcpdump, it looks like their
 157       -- software is getting confused: they send us some XML in
 158       -- the middle of the log-in procedure. In any case, the easiest
 159       -- fix is to disconnect and try again.
 160       --
 161       login_worked <- timeout five_seconds $ log_in cfg h
 162       case login_worked of
 163         Nothing -> putStrLn "Login timed out (5s)."
 164         Just _ ->  loop cfg h []
 165
 166
 167 -- | A wrapper around threadDelay which takes seconds instead of
 168 --   microseconds as its argument.
 169 --
 170 thread_sleep :: Int -> IO ()
 171 thread_sleep seconds = do
 172   let microseconds = seconds * (10 ^ (6 :: Int))
 173   threadDelay microseconds
 174
 175
 176 -- | The entry point of the program.
 177 main :: IO ()
 178 main = do
 179   rc_cfg <- OC.from_rc
 180   cmd_cfg <- get_args
 181
 182   -- Merge the config file options with the command-line ones,
 183   -- prefering the command-line ones.
 184   let opt_config = rc_cfg <> cmd_cfg
 185
 186   -- This is necessary because if the user specifies an empty list of
 187   -- hostnames in e.g. the config file, we want to bail rather than
 188   -- fall back on the default list (which gets merged from a
 189   -- Configuration below).
 190   when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do
 191     report_error "ERROR: no feed hosts supplied."
 192     exitWith (ExitFailure exit_no_feed_hosts)
 193
 194   when (isNothing (OC.password opt_config)) $ do
 195     report_error "ERROR: no password supplied."
 196     exitWith (ExitFailure exit_no_password)
 197
 198   when (isNothing (OC.username opt_config)) $ do
 199     report_error "ERROR: no username supplied."
 200     exitWith (ExitFailure exit_no_username)
 201
 202   -- Finally, update a default config with any options that have been
 203   -- set in either the config file or on the command-line.
 204   let cfg = (def :: Configuration) `merge_optional` opt_config
 205
 206   -- This may be superstition (and I believe stderr is unbuffered),
 207   -- but it can't hurt.
 208   hSetBuffering stderr NoBuffering
 209   hSetBuffering stdout NoBuffering
 210
 211   -- Begin connecting to our feed hosts, starting with the first one.
 212   round_robin cfg 0
 213
 214   where
 215     -- | This is the top-level "loop forever" function. If an
 216     --   exception is thrown, it will propagate up to this point, where
 217     --   it will be logged and ignored in style.
 218     --
 219     --   Afterwards, we recurse (call ourself) again to loop more forevers.
 220     --
 221     round_robin :: Configuration -> Int -> IO ()
 222     round_robin cfg feed_host_idx = do
 223       let hosts = get_feed_hosts $ feed_hosts cfg
 224       let host = hosts !! feed_host_idx
 225       catchIOError (connect_and_loop cfg host) (report_error . show)
 226       thread_sleep 10 -- Wait 10s before attempting to reconnect.
 227       round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)