From: Michael Orlitzky Date: Sun, 29 Dec 2013 01:19:39 +0000 (-0500) Subject: Add a backend configuration option. X-Git-Tag: 0.0.1~151 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=9d278c8b8eeff1a1317f2c3b0f7fdf5fb759ffb3;p=dead%2Fhtsn-import.git Add a backend configuration option. Add command-line parsing. Depend on the new library htsn-common. Remove the TODO since it was empty. --- diff --git a/doc/TODO b/doc/TODO deleted file mode 100644 index d551396..0000000 --- a/doc/TODO +++ /dev/null @@ -1 +0,0 @@ -1. Replace Logging/Terminal with a common version shared by htsn. diff --git a/htsn-import.cabal b/htsn-import.cabal index 4136b1e..8c651a9 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -21,6 +21,7 @@ executable htsn-import directory == 1.2.*, filepath == 1.3.*, hslogger == 1.2.*, + htsn-common == 0.0.1, hxt == 9.3.*, groundhog == 0.4.*, groundhog-sqlite == 0.4.*, diff --git a/src/Backend.hs b/src/Backend.hs new file mode 100644 index 0000000..04cf6ca --- /dev/null +++ b/src/Backend.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Backend ( + Backend(..) ) +where + +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) +import System.Console.CmdArgs.Default ( Default(..) ) + +-- | An enumeration type for the allowed database backends. +data Backend = Sqlite | Postgres + deriving (Data, Read, Show, Typeable) + +instance Default Backend where + def = Sqlite diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 index 0000000..28768f9 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,83 @@ +-- | Parse the command-line options, and display help text if +-- necessary. +module CommandLine ( + get_args ) +where + +import System.Console.CmdArgs ( + (&=), + args, + cmdArgs, + def, + details, + help, + program, + summary, + typ, + typFile ) + +-- This let's us get the version from Cabal. +import Paths_htsn_import (version) +import Data.Version (showVersion) + +import OptionalConfiguration ( OptionalConfiguration(..) ) + +-- | The description of the program, displayed as part of the help. +description :: String +description = "Import XML files from The Sports Network into an RDBMS." + +-- | The name of this program. +program_name :: String +program_name = "htsn-import" + +-- | A summary string output as part of the help. +my_summary :: String +my_summary = program_name ++ "-" ++ (showVersion version) + +-- | A description of the "backend" option. +backend_help :: String +backend_help = + "Database choice, either \"Sqlite\" or \"Postgres\"." + +-- | A description of the "connection_string" option. +connection_string_help :: String +connection_string_help = + "A database-specific connection string (depends on the backend)." + +-- | A description of the "log_file" option. +log_file_help :: String +log_file_help = + "Log to the given file." + +-- | A description of the "log_level" option. +log_level_help :: String +log_level_help = + "How verbose should the logs be? One of INFO, WARNING, ERROR." + +-- | A description of the "syslog" option. +syslog_help :: String +syslog_help = + "Enable logging to syslog." + + +-- | A data structure representing the possible command-line +-- options. The CmdArgs library is doing heavy magic beneath the +-- hood here. +arg_spec :: OptionalConfiguration +arg_spec = + OptionalConfiguration { + backend = def &= typ "BACKEND" &= help backend_help, + connection_string = def &= typ "STRING" &= help connection_string_help, + log_file = def &= typFile &= help log_file_help, + log_level = def &= typ "LEVEL" &= help log_level_help, + syslog = def &= typ "BOOL" &= help syslog_help, + xml_files = def &= typ "XMLFILES" &= args } + &= program program_name + &= summary my_summary + &= details [description] + + +-- | A convenience function; our only export. Meant to be used in +-- 'main' to retrieve the command-line arguments. +get_args :: IO OptionalConfiguration +get_args = cmdArgs arg_spec diff --git a/src/Configuration.hs b/src/Configuration.hs index feefe92..d56cc93 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -10,15 +10,16 @@ where import System.Console.CmdArgs.Default ( Default(..) ) import System.Log ( Priority( INFO ) ) +import Backend ( Backend(..) ) import qualified OptionalConfiguration as OC ( OptionalConfiguration(..), merge_maybes ) - -- | The main configuration data type. This will be passed to most of -- the important functions once it has been created. data Configuration = Configuration { + backend :: Backend, connection_string :: String, log_file :: Maybe FilePath, log_level :: Priority, @@ -29,10 +30,11 @@ data Configuration = -- values. instance Default Configuration where def = Configuration { + backend = def, connection_string = def, log_file = def, log_level = INFO, - syslog = def } + syslog = def } -- | Merge a Configuration with an OptionalConfiguration. This is more @@ -43,6 +45,7 @@ merge_optional :: Configuration -> Configuration merge_optional cfg opt_cfg = Configuration + (merge (backend cfg) (OC.backend opt_cfg)) (merge (connection_string cfg) (OC.connection_string opt_cfg)) (OC.merge_maybes (log_file cfg) (OC.log_file opt_cfg)) (merge (log_level cfg) (OC.log_level opt_cfg)) diff --git a/src/ExitCodes.hs b/src/ExitCodes.hs new file mode 100644 index 0000000..7371e86 --- /dev/null +++ b/src/ExitCodes.hs @@ -0,0 +1,17 @@ +-- | All exit codes that the program can return (excepting +-- ExitSuccess). +-- +module ExitCodes ( + exit_no_connection_string, + exit_no_xml_files ) +where + +-- | No connection string was given on the command line or in the +-- config file. +exit_no_connection_string :: Int +exit_no_connection_string = 1 + +-- | No XML files were given on the command line. +exit_no_xml_files :: Int +exit_no_xml_files = 2 + diff --git a/src/Logging.hs b/src/Logging.hs deleted file mode 100644 index 313781f..0000000 --- a/src/Logging.hs +++ /dev/null @@ -1,82 +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-import[$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-import[$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 index 11cbfae..9151a8e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,6 +2,8 @@ module Main where import Control.Arrow ( (&&&), arr, returnA ) +import Control.Monad ( when ) +import Control.Monad.IO.Class ( liftIO ) import Database.Groundhog.Core ( PersistEntity ) import Database.Groundhog.Sqlite ( defaultMigrationLogger, @@ -10,6 +12,10 @@ import Database.Groundhog.Sqlite ( runDbConn, runMigration, withSqliteConn ) +import Data.Maybe ( isNothing ) +import Data.Monoid ( (<>) ) +import System.Console.CmdArgs ( def ) +import System.Exit ( exitWith, ExitCode (ExitFailure) ) import Text.XML.HXT.Core ( ArrowXml, IOStateArrow, @@ -31,7 +37,19 @@ import Text.XML.HXT.Core ( withValidate, xpickle, yes ) -import System.Environment ( getArgs ) + +import CommandLine ( get_args ) +import Configuration ( Configuration(..), merge_optional ) +import ExitCodes ( + exit_no_connection_string, + exit_no_xml_files ) +import Network.Services.TSN.Logging ( init_logging ) +import qualified OptionalConfiguration as OC ( + OptionalConfiguration ( connection_string, xml_files ), + from_rc ) +import Network.Services.TSN.Report ( + report_info, + report_error ) import qualified TSN.Injuries as Injuries ( Listing, Message ( listings ) ) @@ -41,6 +59,7 @@ import qualified TSN.InjuriesDetail as InjuriesDetail ( PlayerListing ) + -- | A list of options passed to 'readDocument' when we parse an XML -- document. We don't validate because the DTDs from TSN are -- wrong. As a result, we don't want to keep useless DTDs @@ -68,10 +87,11 @@ import_generic dummy g xml = withSqliteConn "foo.sqlite3" $ runDbConn $ do runMigration defaultMigrationLogger $ do migrate dummy - let msg = unpickleDoc xpickle xml - case msg of - Nothing -> error "Should unpickle!" - Just m -> mapM_ (\l -> insert l) (g m) + let root_element = unpickleDoc xpickle xml + case root_element of + Nothing -> let msg = "Could not unpickle document in import_generic." + in liftIO $ report_error msg + Just elt -> mapM_ (\l -> insert l) (g elt) -- | Import TSN.Injuries from an 'XmlTree'. import_injuries :: XmlTree -> IO () @@ -89,9 +109,10 @@ import_injuries_detail = import_file :: FilePath -> IO () import_file path = do + report_info $ "Attempting to import " ++ path ++ "." results <- runX $ readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd) case results of - [] -> error "ERROR: Unable to determine DOCTYPE." + [] -> report_error $ "Unable to determine DTD for file " ++ path ++ "." (r:_) -> r -- Need to do something with the result or it gets GCed? -- We do only expect one result fortunately. where @@ -110,10 +131,37 @@ import_file path = do import_with_dtd (dtd,xml) | dtd == "injuriesxml.dtd" = import_injuries xml | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail xml - | otherwise = error "ERROR: Unrecognized DTD." + | otherwise = report_info $ + "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." main :: IO () main = do - args <- getArgs - import_file (args !! 0) + rc_cfg <- OC.from_rc + cmd_cfg <- get_args + + -- Merge the config file options with the command-line ones, + -- prefering the command-line ones. + let opt_config = rc_cfg <> cmd_cfg + + -- Update a default config with any options that have been set in + -- either the config file or on the command-line. We initialize + -- 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) + + -- Check the optional config for missing required options. + when (null $ OC.xml_files opt_config) $ do + report_error "No XML files given." + exitWith (ExitFailure exit_no_xml_files) + + -- There's a default connection string, namely the empty string, but + -- it's not much use to us. So we make sure that we were given + -- something explicitly. + when (isNothing (OC.connection_string opt_config)) $ do + report_error "No connection string supplied." + exitWith (ExitFailure exit_no_connection_string) + + + return () diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs index f44f77a..ce99f5f 100644 --- a/src/OptionalConfiguration.hs +++ b/src/OptionalConfiguration.hs @@ -31,9 +31,10 @@ import System.Directory ( getHomeDirectory ) import System.FilePath ( () ) import System.IO.Error ( catchIOError ) import System.Log ( Priority(..) ) +import Text.Read ( readMaybe ) -import Logging ( log_error ) -- Can't import report_error from Main -import Terminal ( display_error ) -- 'cause of circular imports. +import Backend ( Backend(..) ) +import Network.Services.TSN.Report ( report_error ) -- Derive standalone instances of Data and Typeable for Priority. This @@ -49,10 +50,12 @@ deriving instance Typeable Priority -- data OptionalConfiguration = OptionalConfiguration { + backend :: Maybe Backend, connection_string :: Maybe String, log_file :: Maybe FilePath, log_level :: Maybe Priority, - syslog :: Maybe Bool } + syslog :: Maybe Bool, + xml_files :: [FilePath] } deriving (Show, Data, Typeable) @@ -76,17 +79,20 @@ merge_maybes (Just _) (Just y) = Just y -- instance Monoid OptionalConfiguration where -- | An empty OptionalConfiguration. - mempty = OptionalConfiguration Nothing Nothing Nothing Nothing + mempty = OptionalConfiguration Nothing Nothing Nothing Nothing Nothing [] -- | Combine @cfg1@ and @cfg2@, giving precedence to @cfg2@. + -- XML files can only be specified on the command-line, so we + -- just join them together here. cfg1 `mappend` cfg2 = OptionalConfiguration + (merge_maybes (backend cfg1) (backend cfg2)) (merge_maybes (connection_string cfg1) (connection_string cfg2)) (merge_maybes (log_file cfg1) (log_file cfg2)) (merge_maybes (log_level cfg1) (log_level cfg2)) (merge_maybes (syslog cfg1) (syslog cfg2)) - + ((xml_files cfg1) ++ (xml_files cfg2)) instance DCT.Configured Priority where -- | This allows us to read a Priority level out of a Configurator @@ -111,24 +117,27 @@ instance DCT.Configured Priority where 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 "htsn-importrc" let user_config_path = home ".htsn-importrc" cfg <- DC.load [ DC.Optional global_config_path, DC.Optional user_config_path ] + cfg_backend <- DC.lookup cfg "backend" cfg_connection_string <- DC.lookup cfg "connection_string" cfg_log_file <- DC.lookup cfg "log_file" cfg_log_level <- DC.lookup cfg "log_level" cfg_syslog <- DC.lookup cfg "syslog" - + let cfg_xml_files = [] -- This won't be in the config file. return $ OptionalConfiguration + (case cfg_backend of -- Try to convert a String to a Backend. + Nothing -> Nothing + Just s -> readMaybe s) cfg_connection_string cfg_log_file cfg_log_level cfg_syslog + cfg_xml_files diff --git a/src/Terminal.hs b/src/Terminal.hs deleted file mode 100644 index 064c5ff..0000000 --- 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