packages feed

htsn 0.0.3 → 0.0.4

raw patch · 14 files changed

+242/−398 lines, 14 filesdep +htsn-commondep −ansi-terminaldep −transformersdep ~tasty

Dependencies added: htsn-common

Dependencies removed: ansi-terminal, transformers

Dependency ranges changed: tasty

Files

doc/htsnrc.example view
@@ -67,8 +67,11 @@  # (Daemon mode only) Create a PID file in the given location. This is # used by the init system on Unix to keep track of the running-# daemon. Its parent directory must be writable by the user/group that-# we will run as!+# daemon.+#+# If necessary, its parent directory will be created with owner/group+# set to the appropriate user/group, but at most one directory will be+# created (that is, we won't create an entire directory tree). # # Default: /run/htsn/htsn.pid #
doc/man1/htsn.1 view
@@ -99,8 +99,10 @@ .IP \fB\-\-pidfile\fR (Daemon mode only) Create a PID file in the given location. This is used by the init system on Unix to keep track of the running daemon.-Its parent directory must be writable by the user/group that we will-run as!++If necessary, its parent directory will be created with owner/group+set to the appropriate user/group, but at most one directory will be+created (that is, we won't create an entire directory tree).  Default: /run/htsn/htsn.pid
htsn.cabal view
@@ -1,5 +1,5 @@ name:           htsn-version:        0.0.3+version:        0.0.4 cabal-version:  >= 1.8 author:         Michael Orlitzky maintainer:	Michael Orlitzky <michael@orlitzky.com>@@ -128,9 +128,11 @@   .   (Daemon mode only) Create a PID file in the given location. This is   used by the init system on Unix to keep track of the running daemon.-  Its parent directory must be writable by the user/group that we will-  run as!   .+  If necessary, its parent directory will be created with owner/group+  set to the appropriate user/group, but at most one directory will+  be created (that is, we won't create an entire directory tree).+  .   Default: \/run\/htsn\/htsn.pid   .   @@@ -203,7 +205,6 @@  executable htsn   build-depends:-    ansi-terminal               == 0.6.*,     base                        == 4.*,     cmdargs                     >= 0.10.6,     configurator                == 0.2.*,@@ -211,12 +212,12 @@     filepath                    == 1.3.*,     hdaemonize                  == 0.4.*,     hslogger                    == 1.2.*,+    htsn-common                 == 0.0.1,     hxt                         == 9.3.*,     MissingH                    == 1.2.*,     network                     == 2.4.*,-    tasty                       == 0.6.*,+    tasty                       == 0.7.*,     tasty-hunit                 == 0.4.*,-    transformers                == 0.3.*,     unix                        == 2.6.*    main-is:@@ -229,12 +230,10 @@     CommandLine     Configuration     ExitCodes-    Logging+    FeedHosts     OptionalConfiguration-    Terminal-    TSN.FeedHosts-    TSN.Xml     Unix+    Xml    ghc-options:     -Wall@@ -265,7 +264,6 @@   hs-source-dirs: src test   main-is: TestSuite.hs   build-depends:-    ansi-terminal               == 0.6.*,     base                        == 4.*,     cmdargs                     >= 0.10.6,     configurator                == 0.2.*,@@ -273,12 +271,12 @@     filepath                    == 1.3.*,     hdaemonize                  == 0.4.*,     hslogger                    == 1.2.*,+    htsn-common                 == 0.0.1,     hxt                         == 9.3.*,     MissingH                    == 1.2.*,     network                     == 2.4.*,-    tasty                       == 0.6.*,+    tasty                       == 0.7.*,     tasty-hunit                 == 0.4.*,-    transformers                == 0.3.*,     unix                        == 2.6.*    -- It's not entirely clear to me why I have to reproduce all of this.
src/Configuration.hs view
@@ -13,7 +13,7 @@ import qualified OptionalConfiguration as OC (   OptionalConfiguration(..),   merge_maybes )-import TSN.FeedHosts (FeedHosts(..))+import FeedHosts (FeedHosts(..))  -- | The main configuration data type. This will be passed to most of --   the important functions once it has been created.
+ src/FeedHosts.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | A newtype around a list of Strings which represent the feed+--   hosts. This is all to avoid an orphan instance of Configured for+--   [String] if we had defined one in e.g. OptionalConfiguration.+--+--   This was placed under the "TSN" namespace because its Default+--   instance is specific to TSN, even though otherwise it's just a+--   list of strings.+--+module FeedHosts+where++-- DC is needed only for the DCT.Configured instance of String.+import qualified Data.Configurator as DC()+import qualified Data.Configurator.Types as DCT (+  Configured,+  Value( List ),+  convert )+import Data.Data (Data)+import System.Console.CmdArgs.Default (Default(..))+import Data.Typeable (Typeable)+++-- | A (wrapper around a) list of hostnames that supply the XML feed.+--+newtype FeedHosts =+  FeedHosts { get_feed_hosts :: [String] }+    deriving (Data, Show, Typeable)+++instance Default FeedHosts where+  -- | The default list of feed hosts. These were found by checking+  --   PTR records in the neighborhood of the IP address in use. There+  --   is a feed4.sportsnetwork.com, but it was not operational when+  --   this was written.+  def = FeedHosts ["feed1.sportsnetwork.com",+                   "feed2.sportsnetwork.com",+                   "feed3.sportsnetwork.com"]+++instance DCT.Configured FeedHosts where+  -- | This allows us to read a FeedHosts object out of a Configurator+  --   config file. By default Configurator wouldn't know what to do,+  --   so we have to tell it that we expect a list, and if that list+  --   has strings in it, we can apply the FeedHosts constructor to+  --   it.+  convert (DCT.List xs) =+    -- mapM gives us a Maybe [String] here.+    fmap FeedHosts (mapM convert_string xs)+    where+      convert_string :: DCT.Value -> Maybe String+      convert_string = DCT.convert++  -- If we read anything other than a list of values out of the file,+  -- fail.+  convert _ = Nothing
− src/Logging.hs 
@@ -1,81 +0,0 @@-module Logging (-  init_logging,-  log_debug,-  log_error,-  log_info,-  log_warning )-where--import Control.Monad ( when )-import System.Log.Formatter ( simpleLogFormatter )-import System.Log.Handler ( setFormatter )-import System.Log.Handler.Simple ( GenericHandler, fileHandler )-import System.Log.Handler.Syslog (-  Facility ( USER ),-  openlog )-import System.Log.Logger (-  Priority ( INFO ),-  addHandler,-  debugM,-  errorM,-  infoM,-  rootLoggerName,-  setHandlers,-  setLevel,-  updateGlobalLogger,-  warningM )----- | Log a message at the DEBUG level.-log_debug :: String -> IO ()-log_debug = debugM rootLoggerName---- | Log a message at the ERROR level.-log_error :: String -> IO ()-log_error = errorM rootLoggerName---- | Log a message at the INFO level.-log_info :: String -> IO ()-log_info = infoM rootLoggerName---- | Log a message at the WARNING level.-log_warning :: String -> IO ()-log_warning = warningM rootLoggerName----- | Set up the logging. All logs are handled by the global "root"---   logger provided by HSLogger. We remove all of its handlers so---   that it does nothing; then we conditionally add back two handlers---   -- one for syslog, and one for a normal file -- dependent upon---   the 'syslog' and 'log_file' configuration items.------   Why don't we take a Configuration as an argument? Because it---   would create circular imports!-init_logging :: Maybe FilePath -> Priority -> Bool -> IO ()-init_logging log_file log_level syslog = do-  -- First set the global log level and clear the default handler.-  let no_handlers = [] :: [GenericHandler a]-  updateGlobalLogger rootLoggerName (setLevel log_level .-                                              setHandlers no_handlers)--  when syslog $ do-    let min_level = INFO-    let sl_level = if log_level < min_level then min_level else log_level--    -- The syslog handle gets its own level which will cowardly refuse-    -- to log all debug info (i.e. the entire feed) to syslog.-    sl_handler' <- openlog rootLoggerName [] USER sl_level--    -- Syslog should output the date by itself.-    let sl_formatter = simpleLogFormatter "htsn[$pid] $prio: $msg"-    let sl_handler = setFormatter sl_handler' sl_formatter--    updateGlobalLogger rootLoggerName (addHandler sl_handler)--  case log_file of-    Nothing -> return ()-    Just lf -> do-      lf_handler' <- fileHandler lf log_level-      let lf_formatter = simpleLogFormatter "$time: htsn[$pid] $prio: $msg"-      let lf_handler = setFormatter lf_handler' lf_formatter-      updateGlobalLogger rootLoggerName (addHandler lf_handler)
src/Main.hs view
@@ -5,7 +5,7 @@ where  import Control.Concurrent ( threadDelay )-import Control.Exception.Base ( bracket )+import Control.Exception ( bracket, throw ) import Control.Monad ( when ) import Data.List ( isPrefixOf ) import Data.Maybe ( isNothing )@@ -37,62 +37,21 @@   exit_no_password,   exit_no_username,   exit_pidfile_exists )-import Logging (-  init_logging,-  log_debug,-  log_error,-  log_info,-  log_warning )+import FeedHosts ( FeedHosts(..) )+import Network.Services.TSN.Logging ( init_logging ) import qualified OptionalConfiguration as OC (   OptionalConfiguration(..),   from_rc )-import Terminal (-  display_debug,-  display_error,-  display_info,-  display_sent,-  display_warning )-import TSN.FeedHosts ( FeedHosts(..) )-import TSN.Xml ( parse_xmlfid )+import Network.Services.TSN.Report (+  report_debug,+  report_info,+  report_warning,+  report_error )+import Network.Services.TSN.Terminal ( display_sent )+import Xml ( parse_xmlfid ) import Unix ( full_daemonize ) --- | Display and log debug information. WARNING! This does not---   automatically append a newline. The output is displayed/logged---   as-is, for, you know, debug purposes.-report_debug :: String -> IO ()-report_debug s = do-  display_debug s-  log_debug s ---- | Display and log an error condition. This will prefix the error---   with "ERROR: " when displaying (but not logging) it so that it---   stands out.----report_error :: String -> IO ()-report_error s = do-  display_error $ "ERROR: " ++ s-  log_error s----- | Display and log an informational (status) message.----report_info :: String -> IO ()-report_info s = do-  display_info s-  log_info s----- | Display and log a warning. This will prefix the warning with---   "WARNING: " when displaying (but not logging) it so that it---   stands out.----report_warning :: String -> IO ()-report_warning s = do-  display_warning $ "WARNING: " ++ s-  log_warning s-- -- | Receive a single line of text from a Handle, and send it to the --   debug log. --@@ -297,7 +256,7 @@   -- logging before the missing parameter checks below so that we can   -- log the errors.   let cfg = (def :: Configuration) `merge_optional` opt_config-  init_logging (log_file cfg) (log_level cfg) (syslog cfg)+  init_logging (log_level cfg) (log_file cfg) (syslog cfg)    -- Check the optional config for missing required options. This is   -- necessary because if the user specifies an empty list of@@ -337,7 +296,7 @@    -- If we were asked to daemonize, do that; otherwise just run the thing.   if (daemonize cfg)-  then full_daemonize cfg run_program+  then try_daemonize cfg run_program   else run_program    where@@ -354,3 +313,16 @@       catchIOError (connect_and_parse cfg host) (report_error . show)       thread_sleep 5 -- Wait 5s before attempting to reconnect.       round_robin cfg $ (feed_host_idx + 1) `mod` (length hosts)+++    -- | A exception handler around full_daemonize. If full_daemonize+    --   doesn't work, we report the error and crash. This is fine; we+    --   only need the program to be resilient once it actually starts.+    --+    try_daemonize :: Configuration -> IO () -> IO ()+    try_daemonize cfg program =+      catchIOError+        (full_daemonize cfg program)+        (\e -> do+          report_error (show e)+          throw e)
src/OptionalConfiguration.hs view
@@ -34,9 +34,8 @@ import System.IO.Error ( catchIOError ) import System.Log ( Priority(..) ) -import Logging ( log_error ) -- Can't import report_error from Main-import Terminal ( display_error ) -- 'cause of circular imports.-import TSN.FeedHosts ( FeedHosts(..) )+import FeedHosts ( FeedHosts(..) )+import Network.Services.TSN.Report ( report_error )   -- Derive standalone instances of Data and Typeable for Priority. This@@ -145,12 +144,10 @@ from_rc :: IO OptionalConfiguration from_rc = do   etc  <- catchIOError getSysconfDir (\e -> do-                                        display_error (show e)-                                        log_error (show e)+                                        report_error (show e)                                         return "/etc")   home <- catchIOError getHomeDirectory (\e -> do-                                           display_error (show e)-                                           log_error (show e)+                                           report_error (show e)                                            return "$(HOME)")   let global_config_path = etc </> "htsnrc"   let user_config_path = home </> ".htsnrc"
− src/TSN/FeedHosts.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | A newtype around a list of Strings which represent the feed---   hosts. This is all to avoid an orphan instance of Configured for---   [String] if we had defined one in e.g. OptionalConfiguration.------   This was placed under the "TSN" namespace because its Default---   instance is specific to TSN, even though otherwise it's just a---   list of strings.----module TSN.FeedHosts-where---- DC is needed only for the DCT.Configured instance of String.-import qualified Data.Configurator as DC()-import qualified Data.Configurator.Types as DCT (-  Configured,-  Value( List ),-  convert )-import Data.Data (Data)-import System.Console.CmdArgs.Default (Default(..))-import Data.Typeable (Typeable)----- | A (wrapper around a) list of hostnames that supply the XML feed.----newtype FeedHosts =-  FeedHosts { get_feed_hosts :: [String] }-    deriving (Data, Show, Typeable)---instance Default FeedHosts where-  -- | The default list of feed hosts. These were found by checking-  --   PTR records in the neighborhood of the IP address in use. There-  --   is a feed4.sportsnetwork.com, but it was not operational when-  --   this was written.-  def = FeedHosts ["feed1.sportsnetwork.com",-                   "feed2.sportsnetwork.com",-                   "feed3.sportsnetwork.com"]---instance DCT.Configured FeedHosts where-  -- | This allows us to read a FeedHosts object out of a Configurator-  --   config file. By default Configurator wouldn't know what to do,-  --   so we have to tell it that we expect a list, and if that list-  --   has strings in it, we can apply the FeedHosts constructor to-  --   it.-  convert (DCT.List xs) =-    -- mapM gives us a Maybe [String] here.-    fmap FeedHosts (mapM convert_string xs)-    where-      convert_string :: DCT.Value -> Maybe String-      convert_string = DCT.convert--  -- If we read anything other than a list of values out of the file,-  -- fail.-  convert _ = Nothing
− src/TSN/Xml.hs 
@@ -1,88 +0,0 @@--- | Minimal XML functionality needed to parse each document's---   XML_File_ID.----module TSN.Xml (-  parse_xmlfid,-  xml_tests )-where--import Data.Either.Utils ( maybeToEither )-import Test.Tasty ( TestTree, testGroup )-import Test.Tasty.HUnit ( (@?=), Assertion, testCase )-import Text.Read ( readMaybe )-import Text.XML.HXT.Core (-  (>>>),-  (/>),-  getChildren,-  getText,-  hasName,-  runLA,-  xreadDoc )----- | A tiny parser written in HXT to extract the "XML_File_ID" element---   from a document. If we fail to parse an XML_File_ID, we return---   the reason wrapped in a 'Left' constructor. The reason should be---   one of two things:------     1. No XML_File_ID elements were found.------     2. An XML_File_ID element was found, but it could not be read---        into an Integer.------   We use an Either rather than a Maybe because we do expect some---   non-integer XML_File_IDs. In the examples, you will see---   NHL_DepthChart_XML.XML with an XML_File_ID of "49618.61" and---   CFL_Boxscore_XML1.xml with an XML_File_ID of "R28916". According---   to Brijesh Patel of TSN, these are special category files and not---   part of the usual feed.------   We want to report them differently, "just in case."----parse_xmlfid :: String -- ^ The XML Document-             -> Either String Integer-parse_xmlfid doc =-  case parse_results of-    []    -> Left "No XML_File_ID elements found."-    (x:_) -> x-  where-    parse :: String -> [String]-    parse =-      runLA (xreadDoc-               >>> hasName "message"-               />  hasName "XML_File_ID"-               >>> getChildren-               >>> getText)--    read_either_integer :: String -> Either String Integer-    read_either_integer s =-      let msg = "Could not parse XML_File_ID " ++ s ++ " as an integer."-      in-        maybeToEither msg (readMaybe s)--    elements = parse doc-    parse_results = map read_either_integer elements----- * Tasty Tests-xml_tests :: TestTree-xml_tests =-  testGroup-    "XML tests"-    [ xml_file_id_tests ]---xml_file_id_tests :: TestTree-xml_file_id_tests =-  testCase "XML_File_ID is parsed correctly" $ do-    let xmlfids = ["19908216", "19908216", "19908245", "19908246", "19908247"]-    mapM_ check xmlfids-  where-    check :: String -> Assertion-    check xmlfid = do-      xml <- readFile ("test/xml/" ++ xmlfid ++ ".xml")-      let actual = parse_xmlfid xml-      -- The maybeToEither should always succeed here, so the error-      -- message goes unused.-      let expected = maybeToEither "derp" (readMaybe xmlfid)-      actual @?= expected
− src/Terminal.hs 
@@ -1,79 +0,0 @@-module Terminal (-  display_debug,-  display_error,-  display_info,-  display_sent,-  display_warning )-where--import Control.Monad.IO.Class (MonadIO(..))-import System.Console.ANSI (-  SGR( SetColor ),-  Color(..),-  ColorIntensity( Vivid ),-  ConsoleLayer( Foreground ),-  hSetSGR )-import System.IO ( Handle, hPutStr, stderr, stdout )---- | Perform a computation (anything in MonadIO) with the given---   graphics mode(s) enabled. Revert to the previous graphics mode---   after the computation has finished.-with_sgr :: (MonadIO m) => Handle -> [SGR] -> m a -> m a-with_sgr h sgrs computation = do-  liftIO $ hSetSGR h sgrs-  x <- computation-  liftIO $ hSetSGR h []-  return x---- | Perform a computation (anything in MonadIO) with the output set---   to a certain color. Reset to the default color after the---   computation has finished.-with_color :: (MonadIO m) => Handle -> Color -> m a -> m a-with_color h color =-  with_sgr h [SetColor Foreground Vivid color]----- | Write the given String to a handle in color. The funnyCaps are---   for synergy with putstrLn and friends.----hPutStrColor :: Handle -> Color -> String -> IO ()-hPutStrColor h c = with_color h c . hPutStr h----- | Write the given line to a handle in color. The funnyCaps are for---   synergy with putstrLn and friends.----hPutStrColorLn :: Handle -> Color -> String -> IO ()-hPutStrColorLn h c s = hPutStrColor h c (s ++ "\n")----- | Display text sent to the feed on the console. Don't automatically---   append a newline.----display_sent :: String -> IO ()-display_sent = hPutStrColor stdout Green----- | Display debug text on the console. Don't automatically append a---   newline in case the raw text is needed for, uh, debugging.----display_debug :: String -> IO ()-display_debug = putStr----- | Display an informational message on the console.----display_info :: String -> IO ()-display_info = hPutStrColorLn stdout Cyan----- | Display a warning on the console. Uses stderr instead of stdout.----display_warning :: String -> IO ()-display_warning = hPutStrColorLn stderr Yellow----- | Display an error on the console. Uses stderr instead of stdout.----display_error :: String -> IO ()-display_error = hPutStrColorLn stderr Red
src/Unix.hs view
@@ -5,7 +5,10 @@  import Control.Concurrent ( ThreadId, myThreadId ) import Control.Exception ( throwTo )+import Control.Monad ( unless )+import System.Directory ( createDirectory, doesDirectoryExist ) import System.Exit ( ExitCode( ExitSuccess ) )+import System.FilePath ( dropFileName, dropTrailingPathSeparator ) import System.IO.Error ( catchIOError ) import System.Posix (   GroupEntry ( groupID ),@@ -23,6 +26,7 @@   removeLink,   setFileCreationMask,   setGroupID,+  setOwnerAndGroup,   setUserID,   sigTERM ) import System.Posix.Daemonize ( daemonize )@@ -31,8 +35,7 @@   Configuration( pidfile,                  run_as_group,                  run_as_user ))-import Logging ( log_info, log_error )-import Terminal ( display_error )+import Network.Services.TSN.Report ( report_error, report_info )  -- | Retrieve the uid associated with the given system user name. We --   take a Maybe String as an argument so the user name can be passed@@ -60,10 +63,9 @@ -- graceful_shutdown :: Configuration -> ThreadId -> IO () graceful_shutdown cfg main_thread_id = do-  log_info "SIGTERM received, removing PID file and shutting down."+  report_info "SIGTERM received, removing PID file and shutting down."   catchIOError try_nicely (\e -> do-                             display_error (show e)-                             log_error (show e)+                             report_error (show e)                              exitImmediately ExitSuccess )   where     try_nicely = do@@ -71,25 +73,55 @@       throwTo main_thread_id ExitSuccess  +-- | Create the directory in which we intend to store the PID+--   file. This will *not* create any parent directories. The PID+--   directory will have its owner/group changed to the user/group+--   under which we'll be running. No permissions will be set; the+--   system's umask must allow owner-write.+--+--   This is intended to create one level beneath either /var/run or+--   /run which often do not survive a reboot.+--+--   If the directory already exists, it is left alone; that is, we+--   don't change its owner/group.+--+create_pid_directory :: FilePath -- ^ The directory to contain the PID file.+                     -> UserID   -- ^ Owner of the new directory if created.+                     -> GroupID  -- ^ Group of the new directory if created.+                     -> IO ()+create_pid_directory pid_directory uid gid = do+  it_exists <- doesDirectoryExist pid_directory+  unless it_exists $ do+    report_info $ "Creating PID directory " ++ pid_directory+    createDirectory pid_directory+    report_info $ "Changing owner/group of " ++ pid_directory +++                    " to " ++ (show uid) ++ "/" ++ (show gid)+    setOwnerAndGroup pid_directory uid gid+ -- | Write a PID file, install a SIGTERM handler, drop privileges, and --   finally do the daemonization dance. -- full_daemonize :: Configuration -> IO () -> IO () full_daemonize cfg program = do+  uid <- get_user_id (run_as_user cfg)+  gid <- get_group_id (run_as_group cfg)++  -- This will have to be done as root and the result chowned to our+  -- user/group, so it must happen before daemonizing.+  let pid_directory = dropTrailingPathSeparator $ dropFileName $ pidfile cfg+  create_pid_directory pid_directory uid gid+   -- The call to 'daemonize' will set the umask to zero, but we want   -- to retain it. So, we set the umask to zero before 'daemonize'   -- can, so that we can record the previous umask value (returned by   -- setFileCreationMask).   orig_umask <- setFileCreationMask 0-  -- This is the 'daemonize' from System.Posix.Daemonize. If it-  -- doesn't work, we report the error and do not much else.-  catchIOError (daemonize (program' orig_umask))-                 (\e -> do-                    display_error (show e)-                    log_error (show e))++  -- This is the 'daemonize' from System.Posix.Daemonize.+  daemonize (program' orig_umask uid gid)   where     -- We need to do all this stuff *after* we daemonize.-    program' orig_umask = do+    program' orig_umask uid gid = do       -- First we install a signal handler for sigTERM. We need to       -- pass the thread ID to the signal handler so it knows which       -- process to "exit."@@ -98,8 +130,8 @@        -- Next we drop privileges. Group ID has to go first, otherwise       -- you ain't root to change groups.-      get_group_id (run_as_group cfg) >>= setGroupID-      get_user_id  (run_as_user cfg) >>= setUserID+      setGroupID gid+      setUserID uid        -- Now we create the PID file.       pid <- getProcessID
+ src/Xml.hs view
@@ -0,0 +1,88 @@+-- | Minimal XML functionality needed to parse each document's+--   XML_File_ID.+--+module Xml (+  parse_xmlfid,+  xml_tests )+where++import Data.Either.Utils ( maybeToEither )+import Test.Tasty ( TestTree, testGroup )+import Test.Tasty.HUnit ( (@?=), Assertion, testCase )+import Text.Read ( readMaybe )+import Text.XML.HXT.Core (+  (>>>),+  (/>),+  getChildren,+  getText,+  hasName,+  runLA,+  xreadDoc )+++-- | A tiny parser written in HXT to extract the "XML_File_ID" element+--   from a document. If we fail to parse an XML_File_ID, we return+--   the reason wrapped in a 'Left' constructor. The reason should be+--   one of two things:+--+--     1. No XML_File_ID elements were found.+--+--     2. An XML_File_ID element was found, but it could not be read+--        into an Integer.+--+--   We use an Either rather than a Maybe because we do expect some+--   non-integer XML_File_IDs. In the examples, you will see+--   NHL_DepthChart_XML.XML with an XML_File_ID of "49618.61" and+--   CFL_Boxscore_XML1.xml with an XML_File_ID of "R28916". According+--   to Brijesh Patel of TSN, these are special category files and not+--   part of the usual feed.+--+--   We want to report them differently, "just in case."+--+parse_xmlfid :: String -- ^ The XML Document+             -> Either String Integer+parse_xmlfid doc =+  case parse_results of+    []    -> Left "No XML_File_ID elements found."+    (x:_) -> x+  where+    parse :: String -> [String]+    parse =+      runLA (xreadDoc+               >>> hasName "message"+               />  hasName "XML_File_ID"+               >>> getChildren+               >>> getText)++    read_either_integer :: String -> Either String Integer+    read_either_integer s =+      let msg = "Could not parse XML_File_ID " ++ s ++ " as an integer."+      in+        maybeToEither msg (readMaybe s)++    elements = parse doc+    parse_results = map read_either_integer elements+++-- * Tasty Tests+xml_tests :: TestTree+xml_tests =+  testGroup+    "XML tests"+    [ xml_file_id_tests ]+++xml_file_id_tests :: TestTree+xml_file_id_tests =+  testCase "XML_File_ID is parsed correctly" $ do+    let xmlfids = ["19908216", "19908216", "19908245", "19908246", "19908247"]+    mapM_ check xmlfids+  where+    check :: String -> Assertion+    check xmlfid = do+      xml <- readFile ("test/xml/" ++ xmlfid ++ ".xml")+      let actual = parse_xmlfid xml+      -- The maybeToEither should always succeed here, so the error+      -- message goes unused.+      let expected = maybeToEither "derp" (readMaybe xmlfid)+      actual @?= expected
test/TestSuite.hs view
@@ -1,6 +1,6 @@ import Test.Tasty ( TestTree, defaultMain ) -import TSN.Xml ( xml_tests )+import Xml ( xml_tests )  tests :: TestTree tests = xml_tests