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 Logging (
  40   init_logging,
  41   log_debug,
  42   log_error,
  43   log_info,
  44   log_warning )
  45 import qualified OptionalConfiguration as OC (
  46   OptionalConfiguration(..),
  47   from_rc )
  48 import Terminal (
  49   display_debug,
  50   display_error,
  51   display_info,
  52   display_sent,
  53   display_warning )
  54 import TSN.FeedHosts (FeedHosts(..))
  55 import TSN.Xml (parse_xmlfid, xml_prologue)
  56
  57
  58 -- | Warning! This does not automatically append a newline. The output
  59 -- is displayed/logged as-is, for, you know, debug purposes.
  60 report_debug :: String -> IO ()
  61 report_debug s = do
  62   display_debug s
  63   log_debug s
  64
  65 report_error :: String -> IO ()
  66 report_error s = do
  67   display_error $ "ERROR: " ++ s
  68   log_error s
  69
  70 report_info :: String -> IO ()
  71 report_info s = do
  72   display_info s
  73   log_info s
  74
  75 -- | Warning! This does not automatically append a newline.
  76 report_sent :: String -> IO ()
  77 report_sent s = do
  78   display_sent s
  79   log_debug s
  80
  81 report_warning :: String -> IO ()
  82 report_warning s = do
  83   display_warning $ "WARNING: " ++ s
  84   log_warning s
  85
  86
  87 -- | Receive a single line of text from a Handle, and send it to the
  88 --   debug log.
  89 --
  90 recv_line :: Handle -> IO String
  91 recv_line h = do
  92   line <- hGetLine h
  93   report_debug (line ++ "\n")
  94   return line
  95
  96
  97 -- | Takes a Configuration, and an XML document (as a String). The XML
  98 --   document is written to the output directory, as specified by the
  99 --   Configuration.
 100 --
 101 --   This can fail, but we don't purposefully throw any exceptions. If
 102 --   something goes wrong, we would rather log it and keep going.
 103 --
 104 save_document :: Configuration -> String -> IO ()
 105 save_document cfg doc =
 106   case maybe_path of
 107     Nothing ->
 108       report_error "Document missing XML_File_ID element."
 109     Just path -> do
 110       already_exists <- doesFileExist path
 111       when already_exists $ do
 112         let msg = "File " ++ path ++ " already exists, overwriting."
 113         report_warning msg
 114       writeFile path doc
 115       report_info $ "Wrote file: " ++ path ++ "."
 116   where
 117     xmlfid = fmap show (parse_xmlfid doc)
 118     filename = fmap (++ ".xml") xmlfid
 119     maybe_path = fmap ((output_directory cfg) </>) filename
 120
 121
 122 -- | Loop forever, writing the buffer to file whenever a new XML
 123 --   prologue is seen. This is the low-level "loop forever" function
 124 --   that we stay in as long as we are connected to one feed.
 125 --
 126 loop :: Configuration -> Handle -> [String] -> IO ()
 127 loop !cfg !h !buffer = do
 128   line <- recv_line h
 129
 130   if (xml_prologue `isPrefixOf` line && not (null buffer))
 131   then do
 132     -- This is the beginning of a new document, and we have an "old"
 133     -- one to save. The buffer is in reverse (newest first) order,
 134     -- though, so we have to reverse it first. We then concatenate all
 135     -- of its lines into one big string.
 136     let document = concat $ reverse buffer
 137     save_document cfg document
 138     loop cfg h [line] -- Empty the buffer before looping again.
 139   else
 140     -- Append line to the head of the buffer and loop.
 141     loop cfg h (line : buffer)
 142
 143
 144 log_in :: Configuration -> Handle -> IO ()
 145 log_in cfg h = do
 146   prompt1 <- recv_prompt h
 147
 148   if prompt1 /= username_prompt then
 149     report_error "Didn't receive username prompt."
 150   else do
 151     send_line h (username cfg)
 152     prompt2 <- recv_prompt h
 153
 154     if prompt2 /= password_prompt then
 155       report_error "Didn't receive password prompt."
 156     else do
 157       send_line h (password cfg)
 158       _ <- recv_line h -- "The Sports Network"
 159       return ()
 160   where
 161     username_prompt = "Username: "
 162     password_prompt = "Password: "
 163
 164     send_line :: Handle -> String -> IO ()
 165     send_line h' s = do
 166       let line = s ++ "\r\n"
 167       hPutStr h' line
 168       display_sent line
 169
 170     recv_chars :: Int -> Handle -> IO String
 171     recv_chars n h' = do
 172       s <- sequence [ hGetChar h' | _ <- [1..n] ]
 173       report_debug s
 174       return s
 175
 176     recv_prompt :: Handle -> IO String
 177     recv_prompt = recv_chars 10
 178
 179
 180 connect_and_loop :: Configuration -> String -> IO ()
 181 connect_and_loop cfg host = do
 182   report_info $ "Connecting to " ++ host ++ "..."
 183   bracket acquire_handle release_handle action
 184   return ()
 185   where
 186     five_seconds :: Int
 187     five_seconds = 5000000
 188
 189     acquire_handle = connectTo host (PortNumber 4500)
 190     release_handle = hClose
 191     action h = do
 192       -- No buffering anywhere.
 193       hSetBuffering h NoBuffering
 194
 195       -- The feed is often unresponsive after we send out username. It
 196       -- happens in a telnet session, too (albeit less frequently?),
 197       -- so there might be a bug on their end.
 198       --
 199       -- If we dump the packets with tcpdump, it looks like their
 200       -- software is getting confused: they send us some XML in
 201       -- the middle of the log-in procedure. In any case, the easiest
 202       -- fix is to disconnect and try again.
 203       --
 204       login_worked <- timeout five_seconds $ log_in cfg h
 205       case login_worked of
 206         Nothing -> report_info "Login timed out (5s)."
 207         Just _ ->  loop cfg h []
 208
 209
 210 -- | A wrapper around threadDelay which takes seconds instead of
 211 --   microseconds as its argument.
 212 --
 213 thread_sleep :: Int -> IO ()
 214 thread_sleep seconds = do
 215   let microseconds = seconds * (10 ^ (6 :: Int))
 216   threadDelay microseconds
 217
 218
 219 -- | The entry point of the program.
 220 main :: IO ()
 221 main = do
 222   rc_cfg <- OC.from_rc
 223   cmd_cfg <- get_args
 224
 225   -- Merge the config file options with the command-line ones,
 226   -- prefering the command-line ones.
 227   let opt_config = rc_cfg <> cmd_cfg
 228
 229   -- Update a default config with any options that have been set in
 230   -- either the config file or on the command-line.  We initialize
 231   -- logging before the missing parameter checks below so that we can
 232   -- log the errors.
 233   let cfg = (def :: Configuration) `merge_optional` opt_config
 234   init_logging (syslog cfg)
 235
 236   -- Check the optional config for missing required options. This is
 237   -- necessary because if the user specifies an empty list of
 238   -- hostnames in e.g. the config file, we want to bail rather than
 239   -- fall back on the default list (which was merged from a default
 240   -- Configuration above).
 241   when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do
 242     report_error "No feed hosts supplied."
 243     exitWith (ExitFailure exit_no_feed_hosts)
 244
 245   when (isNothing (OC.password opt_config)) $ do
 246     report_error "No password supplied."
 247     exitWith (ExitFailure exit_no_password)
 248
 249   when (isNothing (OC.username opt_config)) $ do
 250     report_error "No username supplied."
 251     exitWith (ExitFailure exit_no_username)
 252
 253   -- This may be superstition (and I believe stderr is unbuffered),
 254   -- but it can't hurt.
 255   hSetBuffering stderr NoBuffering
 256   hSetBuffering stdout NoBuffering
 257
 258   -- Begin connecting to our feed hosts, starting with the first one.
 259   round_robin cfg 0
 260
 261   where
 262     -- | This is the top-level "loop forever" function. If an
 263     --   exception is thrown, it will propagate up to this point, where
 264     --   it will be logged and ignored in style.
 265     --
 266     --   Afterwards, we recurse (call ourself) again to loop more forevers.
 267     --
 268     round_robin :: Configuration -> Int -> IO ()
 269     round_robin cfg feed_host_idx = do
 270       let hosts = get_feed_hosts $ feed_hosts cfg
 271       let host = hosts !! feed_host_idx
 272       catchIOError (connect_and_loop cfg host) (report_error . show)
 273       thread_sleep 10 -- Wait 10s before attempting to reconnect.
 274       round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)