executable htsn
build-depends:
- ansi-terminal == 0.6.*,
base == 4.*,
cmdargs >= 0.10.6,
configurator == 0.2.*,
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:
Configuration
ExitCodes
FeedHosts
- Network.Services.TSN.Logging
OptionalConfiguration
- Network.Services.TSN.Report
- Network.Services.TSN.Terminal
Unix
Xml
hs-source-dirs: src test
main-is: TestSuite.hs
build-depends:
- ansi-terminal == 0.6.*,
base == 4.*,
cmdargs >= 0.10.6,
configurator == 0.2.*,
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.
-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 \
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
+++ /dev/null
-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)
+++ /dev/null
--- | 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
+++ /dev/null
-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
projects / dead / htsn.git / commitdiff