Add command-line parsing.
Depend on the new library htsn-common.
Remove the TODO since it was empty.
+++ /dev/null
-1. Replace Logging/Terminal with a common version shared by htsn.
directory == 1.2.*,
filepath == 1.3.*,
hslogger == 1.2.*,
+ htsn-common == 0.0.1,
hxt == 9.3.*,
groundhog == 0.4.*,
groundhog-sqlite == 0.4.*,
--- /dev/null
+{-# 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
--- /dev/null
+-- | 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
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,
-- 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
-> 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))
--- /dev/null
+-- | 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
+
+++ /dev/null
-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)
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,
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,
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 ) )
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
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 ()
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
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 ()
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
--
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)
--
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
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
+++ /dev/null
-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
projects / dead / htsn-import.git / commitdiff