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)
45 import qualified OptionalConfiguration as OC (
46 OptionalConfiguration(..),
54 import TSN.FeedHosts (FeedHosts(..))
55 import TSN.Xml (parse_xmlfid, xml_prologue)
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 ()
65 report_error :: String -> IO ()
67 display_error $ "ERROR: " ++ s
70 report_info :: String -> IO ()
75 -- | Warning! This does not automatically append a newline.
76 report_sent :: String -> IO ()
81 report_warning :: String -> IO ()
83 display_warning $ "WARNING: " ++ s
87 -- | Receive a single line of text from a Handle, and send it to the
90 recv_line :: Handle -> IO String
93 report_debug (line ++ "\n")
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
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.
104 save_document :: Configuration -> String -> IO ()
105 save_document cfg doc =
108 report_error "Document missing XML_File_ID element."
110 already_exists <- doesFileExist path
111 when already_exists $ do
112 let msg = "File " ++ path ++ " already exists, overwriting."
115 report_info $ "Wrote file: " ++ path ++ "."
117 xmlfid = fmap show (parse_xmlfid doc)
118 filename = fmap (++ ".xml") xmlfid
119 maybe_path = fmap ((output_directory cfg) </>) filename
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.
126 loop :: Configuration -> Handle -> [String] -> IO ()
127 loop !cfg !h !buffer = do
130 if (xml_prologue `isPrefixOf` line && not (null buffer))
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.
140 -- Append line to the head of the buffer and loop.
141 loop cfg h (line : buffer)
144 log_in :: Configuration -> Handle -> IO ()
146 prompt1 <- recv_prompt h
148 if prompt1 /= username_prompt then
149 report_error "Didn't receive username prompt."
151 send_line h (username cfg)
152 prompt2 <- recv_prompt h
154 if prompt2 /= password_prompt then
155 report_error "Didn't receive password prompt."
157 send_line h (password cfg)
158 _ <- recv_line h -- "The Sports Network"
161 username_prompt = "Username: "
162 password_prompt = "Password: "
164 send_line :: Handle -> String -> IO ()
166 let line = s ++ "\r\n"
170 recv_chars :: Int -> Handle -> IO String
172 s <- sequence [ hGetChar h' | _ <- [1..n] ]
176 recv_prompt :: Handle -> IO String
177 recv_prompt = recv_chars 10
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
187 five_seconds = 5000000
189 acquire_handle = connectTo host (PortNumber 4500)
190 release_handle = hClose
192 -- No buffering anywhere.
193 hSetBuffering h NoBuffering
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.
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.
204 login_worked <- timeout five_seconds $ log_in cfg h
206 Nothing -> report_info "Login timed out (5s)."
207 Just _ -> loop cfg h []
210 -- | A wrapper around threadDelay which takes seconds instead of
211 -- microseconds as its argument.
213 thread_sleep :: Int -> IO ()
214 thread_sleep seconds = do
215 let microseconds = seconds * (10 ^ (6 :: Int))
216 threadDelay microseconds
219 -- | The entry point of the program.
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
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
233 let cfg = (def :: Configuration) `merge_optional` opt_config
234 init_logging (syslog cfg)
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)
245 when (isNothing (OC.password opt_config)) $ do
246 report_error "No password supplied."
247 exitWith (ExitFailure exit_no_password)
249 when (isNothing (OC.username opt_config)) $ do
250 report_error "No username supplied."
251 exitWith (ExitFailure exit_no_username)
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
258 -- Begin connecting to our feed hosts, starting with the first one.
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.
266 -- Afterwards, we recurse (call ourself) again to loop more forevers.
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)