diff --git a/doc/htsnrc.example b/doc/htsnrc.example --- a/doc/htsnrc.example +++ b/doc/htsnrc.example @@ -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 # diff --git a/doc/man1/htsn.1 b/doc/man1/htsn.1 --- a/doc/man1/htsn.1 +++ b/doc/man1/htsn.1 @@ -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 diff --git a/htsn.cabal b/htsn.cabal --- a/htsn.cabal +++ b/htsn.cabal @@ -1,5 +1,5 @@ name: htsn -version: 0.0.3 +version: 0.0.4 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky @@ -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. diff --git a/src/Configuration.hs b/src/Configuration.hs --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -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. diff --git a/src/FeedHosts.hs b/src/FeedHosts.hs new file mode 100644 --- /dev/null +++ b/src/FeedHosts.hs @@ -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 diff --git a/src/Logging.hs b/src/Logging.hs deleted file mode 100644 --- a/src/Logging.hs +++ /dev/null @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs --- a/src/OptionalConfiguration.hs +++ b/src/OptionalConfiguration.hs @@ -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" diff --git a/src/TSN/FeedHosts.hs b/src/TSN/FeedHosts.hs deleted file mode 100644 --- a/src/TSN/FeedHosts.hs +++ /dev/null @@ -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 diff --git a/src/TSN/Xml.hs b/src/TSN/Xml.hs deleted file mode 100644 --- a/src/TSN/Xml.hs +++ /dev/null @@ -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 diff --git a/src/Terminal.hs b/src/Terminal.hs deleted file mode 100644 --- a/src/Terminal.hs +++ /dev/null @@ -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 diff --git a/src/Unix.hs b/src/Unix.hs --- a/src/Unix.hs +++ b/src/Unix.hs @@ -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 diff --git a/src/Xml.hs b/src/Xml.hs new file mode 100644 --- /dev/null +++ b/src/Xml.hs @@ -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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,6 +1,6 @@ import Test.Tasty ( TestTree, defaultMain ) -import TSN.Xml ( xml_tests ) +import Xml ( xml_tests ) tests :: TestTree tests = xml_tests