From 39a22e11952c31a1f058c1e457be471381eff6fa Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 28 Dec 2013 19:41:07 -0500 Subject: [PATCH] Move Logging, Report, and Terminal into their own library htsn-common and depend upon it. --- htsn.cabal | 9 +-- makefile | 11 ++-- src/Network/Services/TSN/Logging.hs | 84 ---------------------------- src/Network/Services/TSN/Report.hs | 57 ------------------- src/Network/Services/TSN/Terminal.hs | 79 -------------------------- 5 files changed, 8 insertions(+), 232 deletions(-) delete mode 100644 src/Network/Services/TSN/Logging.hs delete mode 100644 src/Network/Services/TSN/Report.hs delete mode 100644 src/Network/Services/TSN/Terminal.hs diff --git a/htsn.cabal b/htsn.cabal index 72c22be..09c5c0d 100644 --- a/htsn.cabal +++ b/htsn.cabal @@ -203,7 +203,6 @@ description: executable htsn build-depends: - ansi-terminal == 0.6.*, base == 4.*, cmdargs >= 0.10.6, configurator == 0.2.*, @@ -211,12 +210,12 @@ executable htsn 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-hunit == 0.4.*, - transformers == 0.3.*, unix == 2.6.* main-is: @@ -230,10 +229,7 @@ executable htsn Configuration ExitCodes FeedHosts - Network.Services.TSN.Logging OptionalConfiguration - Network.Services.TSN.Report - Network.Services.TSN.Terminal Unix Xml @@ -266,7 +262,6 @@ test-suite testsuite hs-source-dirs: src test main-is: TestSuite.hs build-depends: - ansi-terminal == 0.6.*, base == 4.*, cmdargs >= 0.10.6, configurator == 0.2.*, @@ -274,12 +269,12 @@ test-suite testsuite 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-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/makefile b/makefile index d1b5052..a0d4de7 100644 --- a/makefile +++ b/makefile @@ -1,23 +1,24 @@ -BIN = dist/build/htsn/htsn +PN = htsn +BIN = dist/build/$(PN)/$(PN) TESTSUITE_BIN = dist/build/testsuite/testsuite SRCS := $(shell find src/ -type f -name '*.hs') TEST_SRCS := $(shell find test/ -type f -name '*.hs') .PHONY : dist hlint -$(BIN): $(SRCS) +$(BIN): $(PN).cabal $(SRCS) runghc Setup.hs clean runghc Setup.hs configure --user --prefix=/ runghc Setup.hs build -profile: $(SRCS) +profile: $(PN).cabal $(SRCS) runghc Setup.hs clean runghc Setup.hs configure --user \ --enable-executable-profiling \ --prefix=/ runghc Setup.hs build -doc: *.cabal $(SRCS) +doc: $(PN).cabal $(SRCS) runghc Setup.hs configure --user --prefix=/ runghc Setup.hs hscolour --executables runghc Setup.hs haddock --internal \ @@ -30,7 +31,7 @@ clean: rm -f *.xml rm -rf tmp -$(TESTSUITE_BIN): $(SRCS) $(TEST_SRCS) +$(TESTSUITE_BIN): $(PN).cabal $(SRCS) $(TEST_SRCS) runghc Setup.hs configure --user --enable-tests --prefix=/ runghc Setup.hs build diff --git a/src/Network/Services/TSN/Logging.hs b/src/Network/Services/TSN/Logging.hs deleted file mode 100644 index a20a897..0000000 --- a/src/Network/Services/TSN/Logging.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Network.Services.TSN.Logging ( - init_logging, - log_debug, - log_error, - log_info, - log_warning ) -where - -import Control.Monad ( when ) -import System.Environment ( getProgName ) -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. - program_name <- getProgName - let sl_formatter = simpleLogFormatter $ - program_name ++ "[$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/Network/Services/TSN/Report.hs b/src/Network/Services/TSN/Report.hs deleted file mode 100644 index 2423352..0000000 --- a/src/Network/Services/TSN/Report.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | Convenience functions for reporting (display and/or logging) --- status messages. --- -module Network.Services.TSN.Report ( - report_debug, - report_error, - report_info, - report_warning ) -where - -import Network.Services.TSN.Logging ( - log_debug, - log_error, - log_info, - log_warning ) -import Network.Services.TSN.Terminal ( - display_debug, - display_error, - display_info, - display_warning ) - - --- | 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 diff --git a/src/Network/Services/TSN/Terminal.hs b/src/Network/Services/TSN/Terminal.hs deleted file mode 100644 index e24d23c..0000000 --- a/src/Network/Services/TSN/Terminal.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Network.Services.TSN.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 -- 2.43.2