From: Michael Orlitzky <michael@orlitzky.com>
Date: Sat, 28 Dec 2013 17:35:34 +0000 (-0500)
Subject: Add copies of htsn's Logging and Terminal modules (to be replaced later).
X-Git-Tag: 0.0.1~153
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=2fe07315388ff9d0d6b548bba27ddf25dd692a40;p=dead%2Fhtsn-import.git

Add copies of htsn's Logging and Terminal modules (to be replaced later).
---

diff --git a/src/Logging.hs b/src/Logging.hs
new file mode 100644
index 0000000..313781f
--- /dev/null
+++ b/src/Logging.hs
@@ -0,0 +1,82 @@
+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/Terminal.hs b/src/Terminal.hs
new file mode 100644
index 0000000..064c5ff
--- /dev/null
+++ b/src/Terminal.hs
@@ -0,0 +1,79 @@
+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