From: Michael Orlitzky <michael@orlitzky.com>
Date: Mon, 27 Jan 2014 20:04:51 +0000 (-0500)
Subject: Add a fifteen minute data timeout within the main loop.
X-Git-Tag: 0.0.6~2
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=ac97e3119df309c4eaaff0c72e5b5879f156616f;p=dead%2Fhtsn.git

Add a fifteen minute data timeout within the main loop.
---

diff --git a/src/Main.hs b/src/Main.hs
index dcb38b2..0a2f7d7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -105,28 +105,46 @@ save_document cfg doc =
 --   The bang pattern at least on @buffer@ is necessary for
 --   performance reasons.
 --
+--   We specify a timeout of fifteen minutes on the 'recv_line'
+--   function, after which we will return to our caller. This should
+--   cause the connection to be dropped, and a new one initiated. The
+--   timeout is in response to observed behavior where the feed
+--   eventually stops transmitting data entirely without closing the
+--   connection.
+--
 loop :: Configuration
      -> Handle -- ^ Handle to the feed (network connection)
      -> [String] -- ^ Current XML document buffer, line-by-line, in reverse
      -> IO ()
 loop !cfg !h !buffer = do
-  line <- recv_line h
-  let new_buffer = line : 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 "</message>" `isPrefixOf` line
-  then do
-    -- 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 [] -- Empty the buffer before looping again.
-  else
-    -- Append line to the head of the buffer and loop.
-    loop cfg h new_buffer
+  line' <- timeout fifteen_minutes $ recv_line h
+  case line' of
+    -- If we haven't received anything in fifteen minutes, return back
+    -- to the calling function. This should only happen in the case of
+    -- an error, and our caller should be prepared to handle it.
+    Nothing -> do
+      report_warning $ "No data received for 15 minutes."
+    Just line -> do
+      -- If the recv didn't timeout, proceed normally.
+      let new_buffer = line : 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 "</message>" `isPrefixOf` line
+      then do
+        -- 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 [] -- Empty the buffer before looping again.
+      else
+        -- Append line to the head of the buffer and loop.
+        loop cfg h new_buffer
+  where
+    fifteen_minutes :: Int
+    fifteen_minutes = 15 * 60 * 1000000
 
 
 -- | Once we're connected to a feed, we need to log in. There's no
@@ -208,15 +226,19 @@ connect_and_parse :: Configuration
                   -> String -- ^ Hostname to connect to
                   -> IO ()
 connect_and_parse cfg host = do
-  report_info $ "Connecting to " ++ host ++ "."
   bracket acquire_handle release_handle action
-  return ()
   where
     five_seconds :: Int
-    five_seconds = 5000000
+    five_seconds = 5 * 1000000
+
+    acquire_handle = do
+      report_info $ "Connecting to " ++ host ++ "."
+      connectTo host (PortNumber 4500)
+
+    release_handle = \h -> do
+      report_info $ "Closing connection to " ++ host ++ "."
+      hClose h
 
-    acquire_handle = connectTo host (PortNumber 4500)
-    release_handle = hClose
     action h = do
       -- No buffering anywhere.
       hSetBuffering h NoBuffering
@@ -240,6 +262,10 @@ connect_and_parse cfg host = do
       case login_worked of
         Nothing -> report_info $ "Login timed out (5 seconds). "
                                    ++ "Waiting 5 seconds to reconnect."
+
+        -- If loop returns (due to its timeout), it will pop out right
+        -- here and the action will terminate causing 'release_handle'
+        -- to trigger.
         Just _ ->  loop cfg h []