From eb1187607a616b36bb446650dc141019345eed8f Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 21 Dec 2013 13:44:45 -0500 Subject: [PATCH] Based on TSN documentation, split XML documents on the tag instead of the XML prologue. --- src/Main.hs | 76 ++++++++++++++++++++++++++++++-------------------- src/TSN/Xml.hs | 5 ---- 2 files changed, 46 insertions(+), 35 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 6b18c86..f2febcb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,19 +4,19 @@ module Main where -import Control.Concurrent (threadDelay) -import Control.Exception.Base (bracket) -import Control.Monad (when) -import Data.List (isPrefixOf) -import Data.Maybe (isNothing) -import Data.Monoid ((<>)) +import Control.Concurrent ( threadDelay ) +import Control.Exception.Base ( bracket ) +import Control.Monad ( when ) +import Data.List ( isPrefixOf ) +import Data.Maybe ( isNothing ) +import Data.Monoid ( (<>) ) import Network ( connectTo, PortID (PortNumber) ) -import System.Console.CmdArgs (def) -import System.Directory (doesFileExist) -import System.Exit (ExitCode(..), exitWith) -import System.FilePath (()) +import System.Console.CmdArgs ( def ) +import System.Directory ( doesFileExist ) +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( () ) import System.IO ( BufferMode (NoBuffering), Handle, @@ -27,11 +27,11 @@ import System.IO ( hSetBuffering, stderr, stdout ) -import System.IO.Error (catchIOError) -import System.Timeout (timeout) +import System.IO.Error ( catchIOError ) +import System.Timeout ( timeout ) -import CommandLine (get_args) -import Configuration (Configuration(..), merge_optional) +import CommandLine ( get_args ) +import Configuration ( Configuration(..), merge_optional ) import ExitCodes ( exit_no_feed_hosts, exit_no_password, @@ -51,8 +51,8 @@ import Terminal ( display_info, display_sent, display_warning ) -import TSN.FeedHosts (FeedHosts(..)) -import TSN.Xml (parse_xmlfid, xml_prologue) +import TSN.FeedHosts ( FeedHosts(..) ) +import TSN.Xml ( parse_xmlfid ) -- | Warning! This does not automatically append a newline. The output @@ -119,26 +119,36 @@ save_document cfg doc = maybe_path = fmap ((output_directory cfg) ) filename --- | Loop forever, writing the buffer to file whenever a new XML --- prologue is seen. This is the low-level "loop forever" function --- that we stay in as long as we are connected to one feed. +-- | Loop forever, writing the buffer to file whenever a +-- tag is seen. This is the low-level "loop forever" function that +-- we stay in as long as we are connected to one feed. +-- +-- The documentation at +-- states +-- that \ will always be the root element of the XML +-- documents, and \ will be the final line transmitted +-- for a given document. We therefore rely on this to simplify +-- processing. -- loop :: Configuration -> Handle -> [String] -> IO () loop !cfg !h !buffer = do line <- recv_line h + let new_buffer = line : buffer - if (xml_prologue `isPrefixOf` line && not (null buffer)) + -- Use isPrefixOf to avoid line-ending issues. Hopefully they won't + -- send invalid junk (on the same line) after closing the root + -- element. + if "" `isPrefixOf` line then do - -- This is the beginning of a new document, and we have an "old" - -- one to save. The buffer is in reverse (newest first) order, - -- though, so we have to reverse it first. We then concatenate all - -- of its lines into one big string. - let document = concat $ reverse buffer + -- The buffer is in reverse (newest first) order, though, so we + -- have to reverse it first. We then concatenate all of its lines + -- into one big string. + let document = concat $ reverse new_buffer save_document cfg document - loop cfg h [line] -- Empty the buffer before looping again. + loop cfg h [] -- Empty the buffer before looping again. else -- Append line to the head of the buffer and loop. - loop cfg h (line : buffer) + loop cfg h new_buffer log_in :: Configuration -> Handle -> IO () @@ -198,8 +208,14 @@ connect_and_loop cfg host = do -- -- If we dump the packets with tcpdump, it looks like their -- software is getting confused: they send us some XML in - -- the middle of the log-in procedure. In any case, the easiest - -- fix is to disconnect and try again. + -- the middle of the log-in procedure. + -- + -- On the other hand, the documentation at + -- + -- states that you can only make one connection per username to + -- a given host. So maybe they're simply rejecting the username + -- in an unfriendly fashion. In any case, the easiest fix is to + -- disconnect and try again. -- login_worked <- timeout five_seconds $ log_in cfg h case login_worked of @@ -270,5 +286,5 @@ main = do let hosts = get_feed_hosts $ feed_hosts cfg let host = hosts !! feed_host_idx catchIOError (connect_and_loop cfg host) (report_error . show) - thread_sleep 10 -- Wait 10s before attempting to reconnect. + thread_sleep 5 -- Wait 5s before attempting to reconnect. round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts) diff --git a/src/TSN/Xml.hs b/src/TSN/Xml.hs index ddde728..4c1123f 100644 --- a/src/TSN/Xml.hs +++ b/src/TSN/Xml.hs @@ -3,7 +3,6 @@ -- module TSN.Xml ( parse_xmlfid, - xml_prologue, xml_tests ) where @@ -35,10 +34,6 @@ parse_xmlfid = >>> getText) --- | The opening "tag" for the XML prologue. -xml_prologue :: String -xml_prologue = "