1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DoAndIfThenElse #-}
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 ((<>))
16 import System.Console.CmdArgs (def)
17 import System.Directory (doesFileExist)
18 import System.Exit (ExitCode(..), exitWith)
19 import System.FilePath ((</>))
21 BufferMode (NoBuffering),
30 import System.IO.Error (catchIOError)
31 import System.Timeout (timeout)
33 import CommandLine (get_args)
34 import Configuration (Configuration(..), merge_optional)
39 import qualified OptionalConfiguration as OC (
40 OptionalConfiguration(..),
42 import Terminal (putGreenLn, report_error)
43 import TSN.FeedHosts (FeedHosts(..))
44 import TSN.Xml (parse_xmlfid, xml_prologue)
47 recv_line :: Handle -> IO String
54 save_document :: Configuration -> String -> IO ()
55 save_document cfg doc =
58 report_error "ERROR: document missing XML_File_ID element."
60 already_exists <- doesFileExist path
61 when already_exists $ do
62 let msg = "WARNING: file " ++ path ++ " already exists. Overwriting."
66 xmlfid = fmap show (parse_xmlfid doc)
67 filename = fmap (++ ".xml") xmlfid
68 maybe_path = fmap ((output_directory cfg) </>) filename
70 -- | Loop forever, writing the buffer to file whenever a new XML
72 loop :: Configuration -> Handle -> [String] -> IO ()
73 loop !cfg !h !buffer = do
76 if (xml_prologue `isPrefixOf` line && not (null buffer))
78 -- This is the beginning of a new document, and we have an "old"
79 -- one to save. The buffer is in reverse (newest first) order,
80 -- though, so we have to reverse it first. We then concatenate all
81 -- of its lines into one big string.
82 let document = concat $ reverse buffer
83 save_document cfg document
84 loop cfg h [line] -- empty the buffer before looping again
86 loop cfg h (line : buffer) -- append line to the head of the buffer and loop
89 log_in :: Configuration -> Handle -> IO ()
91 prompt1 <- recv_prompt h
93 if prompt1 /= username_prompt then
94 report_error "ERROR: didn't receive username prompt."
96 send_line h (username cfg)
97 prompt2 <- recv_prompt h
99 if prompt2 /= password_prompt then
100 report_error "ERROR: didn't receive password prompt."
102 send_line h (password cfg)
103 _ <- recv_line h -- "The Sports Network"
106 username_prompt = "Username: "
107 password_prompt = "Password: "
109 send_line :: Handle -> String -> IO ()
111 hPutStr h' (s ++ "\r\n")
114 recv_chars :: Int -> Handle -> IO String
116 s <- sequence [ hGetChar h' | _ <- [1..n] ]
120 recv_prompt :: Handle -> IO String
121 recv_prompt = recv_chars 10
123 connect_and_loop :: Configuration -> String -> IO ()
124 connect_and_loop cfg host = do
125 putStrLn $ "Connecting to " ++ host ++ "..."
126 bracket acquire_handle release_handle action
130 five_seconds = 5000000
132 acquire_handle = connectTo host (PortNumber 4500)
133 release_handle = hClose
135 -- No buffering anywhere.
136 hSetBuffering h NoBuffering
138 -- The feed is often unresponsive after we send out username. It
139 -- happens in a telnet session, too (albeit less frequently?),
140 -- so there might be a bug on their end.
142 -- If we dump the packets with tcpdump, it looks like their
143 -- software is getting confused: they send us some XML in
144 -- the middle of the log-in procedure. In any case, the easiest
145 -- fix is to disconnect and try again.
147 login_worked <- timeout five_seconds $ log_in cfg h
149 Nothing -> putStrLn "Login timed out (5s)."
150 Just _ -> loop cfg h []
153 -- | A wrapper around threadDelay which takes seconds instead of
154 -- microseconds as its argument.
155 thread_sleep :: Int -> IO ()
156 thread_sleep seconds = do
157 let microseconds = seconds * (10 ^ (6 :: Int))
158 threadDelay microseconds
166 -- Merge the config file options with the command-line ones,
167 -- prefering the command-line ones.
168 let opt_config = rc_cfg <> cmd_cfg
170 -- This is necessary because if the user specifies an empty list of
171 -- hostnames in e.g. the config file, we want to bail rather than
172 -- fall back on the default list (which gets merged from a
173 -- Configuration below).
174 when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do
175 report_error "ERROR: no feed hosts supplied."
176 exitWith (ExitFailure exit_no_feed_hosts)
178 when (isNothing (OC.password opt_config)) $ do
179 report_error "ERROR: no password supplied."
180 exitWith (ExitFailure exit_no_password)
182 when (isNothing (OC.username opt_config)) $ do
183 report_error "ERROR: no username supplied."
184 exitWith (ExitFailure exit_no_username)
186 -- Finally, update a default config with any options that have been
187 -- set in either the config file or on the command-line.
188 let cfg = (def :: Configuration) `merge_optional` opt_config
190 hSetBuffering stderr NoBuffering
191 hSetBuffering stdout NoBuffering
196 round_robin :: Configuration -> Int -> IO ()
197 round_robin cfg feed_host_idx = do
198 let hosts = get_feed_hosts $ feed_hosts cfg
199 let host = hosts !! feed_host_idx
200 catchIOError (connect_and_loop cfg host) (report_error . show)
201 thread_sleep 10 -- Wait 10s before attempting to reconnect.
202 round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)