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 (forever, 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
  32 import CommandLine (get_args)
  33 import Configuration (Configuration(..), merge_optional)
  34 import ExitCodes (
  35   exit_no_feed_hosts,
  36   exit_no_password,
  37   exit_no_username )
  38 import FeedHosts (FeedHosts(..))
  39 import qualified OptionalConfiguration as OC (
  40   OptionalConfiguration(..),
  41   from_rc )
  42 import Terminal (hPutRedLn, putGreenLn)
  43 import TSN.Xml (parse_xmlfid, xml_prologue)
  44
  45
  46 report_error :: String -> IO ()
  47 report_error = hPutRedLn stderr
  48
  49
  50 recv_line :: Handle -> IO String
  51 recv_line h = do
  52   line <- hGetLine h
  53   putStrLn line
  54   return line
  55
  56
  57 save_document :: Configuration -> String -> IO ()
  58 save_document cfg doc = do
  59   case maybe_path of
  60     Nothing ->
  61       report_error "ERROR: document missing XML_File_ID element."
  62     Just path -> do
  63       already_exists <- doesFileExist path
  64       when already_exists $ do
  65         let msg = "WARNING: file " ++ path ++ " already exists. Overwriting."
  66         report_error msg
  67       writeFile path doc
  68   where
  69     xmlfid = fmap show (parse_xmlfid doc)
  70     filename = fmap (++ ".xml") xmlfid
  71     maybe_path = fmap ((output_directory cfg) </>) filename
  72
  73 -- | Loop forever, writing the buffer to file whenever a new XML
  74 --   prologue is seen.
  75 loop :: Configuration -> Handle -> [String] -> IO ()
  76 loop !cfg !h !buffer = do
  77   line <- recv_line h
  78
  79   if (xml_prologue `isPrefixOf` line && not (null buffer))
  80   then do
  81     -- This is the beginning of a new document, and we have an "old"
  82     -- one to save. The buffer is in reverse (newest first) order,
  83     -- though, so we have to reverse it first. We then concatenate all
  84     -- of its lines into one big string.
  85     let document = concat $ reverse buffer
  86     save_document cfg document
  87     loop cfg h [line] -- empty the buffer before looping again
  88   else
  89     loop cfg h (line : buffer) -- append line to the head of the buffer and loop
  90
  91
  92 log_in :: Configuration -> Handle -> IO ()
  93 log_in cfg h = do
  94   prompt1 <- recv_prompt h
  95
  96   if prompt1 /= username_prompt then
  97     report_error "ERROR: didn't receive username prompt."
  98   else do
  99     send_line h (username cfg)
 100     prompt2 <- recv_prompt h
 101
 102     if prompt2 /= password_prompt then
 103       report_error "ERROR: didn't receive password prompt."
 104     else do
 105       send_line h (password cfg)
 106       _ <- recv_line h -- "The Sports Network"
 107       return ()
 108   where
 109     username_prompt = "Username: "
 110     password_prompt = "Password: "
 111
 112     send_line :: Handle -> String -> IO ()
 113     send_line h' s = do
 114       hPutStr h' (s ++ "\r\n")
 115       putGreenLn s
 116
 117     recv_chars :: Int -> Handle -> IO String
 118     recv_chars n h' = do
 119       s <- sequence [ hGetChar h' | _ <- [1..n] ]
 120       putStr s
 121       return s
 122
 123     recv_prompt :: Handle -> IO String
 124     recv_prompt = recv_chars 10
 125
 126 connect_and_loop :: Configuration -> IO ()
 127 connect_and_loop cfg =
 128   bracket acquire_handle release_handle action
 129   where
 130     --acquire_handle = connectTo "feed1.sportsnetwork.com" (PortNumber 4500)
 131     acquire_handle = connectTo "feed2.sportsnetwork.com" (PortNumber 4500)
 132     --acquire_handle = connectTo "127.0.0.1" (PortNumber 13337)
 133     release_handle = hClose
 134     action h = do
 135       -- No buffering anywhere.
 136       hSetBuffering h NoBuffering
 137       log_in cfg h
 138       loop cfg h []
 139
 140
 141 -- | A wrapper around threadDelay which takes seconds instead of
 142 --   microseconds as its argument.
 143 thread_sleep :: Int -> IO ()
 144 thread_sleep seconds = do
 145   let microseconds = seconds * (10 ^ (6 :: Int))
 146   threadDelay microseconds
 147
 148
 149 main :: IO ()
 150 main = do
 151   rc_cfg <- OC.from_rc
 152   cmd_cfg <- get_args
 153
 154   -- Merge the config file options with the command-line ones,
 155   -- prefering the command-line ones.
 156   let opt_config = rc_cfg <> cmd_cfg
 157
 158   when (null $ get_feed_hosts (OC.feed_hosts opt_config)) $ do
 159     report_error "ERROR: no feed hosts supplied."
 160     exitWith (ExitFailure exit_no_feed_hosts)
 161
 162   when (isNothing (OC.password opt_config)) $ do
 163     report_error "ERROR: no password supplied."
 164     exitWith (ExitFailure exit_no_password)
 165
 166   when (isNothing (OC.username opt_config)) $ do
 167     report_error "ERROR: no username supplied."
 168     exitWith (ExitFailure exit_no_username)
 169
 170   -- Finally, update a default config with any options that have been
 171   -- set in either the config file or on the command-line.
 172   let cfg = (def :: Configuration) `merge_optional` opt_config
 173
 174   hSetBuffering stderr NoBuffering
 175   hSetBuffering stdout NoBuffering
 176
 177   forever $ do
 178     catchIOError (connect_and_loop cfg) (report_error . show)
 179     thread_sleep 10 -- Wait 10s before attempting to reconnect.