log alerts in notice mode, which is enabled by default

This commit is contained in:
Joey Hess 2013-01-15 14:34:39 -04:00
parent 85c8b222a0
commit b635d99f66
4 changed files with 27 additions and 17 deletions

View file

@ -187,7 +187,7 @@ notifyAlert = do
{- Returns the alert's identifier, which can be used to remove it. -} {- Returns the alert's identifier, which can be used to remove it. -}
addAlert :: Alert -> Assistant AlertId addAlert :: Alert -> Assistant AlertId
addAlert alert = do addAlert alert = do
debug [showAlert alert] notice [showAlert alert]
notifyAlert `after` modifyDaemonStatus add notifyAlert `after` modifyDaemonStatus add
where where
add s = (s { lastAlertId = i, alertMap = m }, i) add s = (s { lastAlertId = i, alertMap = m }, i)

View file

@ -5,7 +5,12 @@
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
module Assistant.Types.NamedThread where module Assistant.Types.NamedThread (
ThreadName,
NamedThread(..),
debug,
notice,
) where
import Common.Annex import Common.Annex
import Assistant.Monad import Assistant.Monad
@ -16,6 +21,12 @@ type ThreadName = String
data NamedThread = NamedThread ThreadName (Assistant ()) data NamedThread = NamedThread ThreadName (Assistant ())
debug :: [String] -> Assistant () debug :: [String] -> Assistant ()
debug ws = do debug = logaction debugM
notice :: [String] -> Assistant ()
notice = logaction noticeM
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
logaction a ws = do
name <- getAssistant threadName name <- getAssistant threadName
liftIO $ debugM name $ unwords $ (name ++ ":") : ws liftIO $ a name $ unwords $ (name ++ ":") : ws

View file

@ -38,6 +38,10 @@ import Text.JSON
import Data.Progress.Meter import Data.Progress.Meter
import Data.Progress.Tracker import Data.Progress.Tracker
import Data.Quantity import Data.Quantity
import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import Common import Common
import Types import Types
@ -197,11 +201,15 @@ showHeader h = handle q $
showRaw :: String -> Annex () showRaw :: String -> Annex ()
showRaw s = handle q $ putStrLn s showRaw s = handle q $ putStrLn s
{- This avoids ghc's output layer crashing on invalid encoded characters in
- filenames when printing them out.
-}
setupConsole :: IO () setupConsole :: IO ()
setupConsole = do setupConsole = do
s <- setFormatter
<$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg")
updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s])
{- This avoids ghc's output layer crashing on
- invalid encoded characters in
- filenames when printing them out. -}
fileEncoding stdout fileEncoding stdout
fileEncoding stderr fileEncoding stderr

View file

@ -17,9 +17,6 @@ module Option (
import System.Console.GetOpt import System.Console.GetOpt
import System.Log.Logger import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import Common.Annex import Common.Annex
import qualified Annex import qualified Annex
@ -51,13 +48,7 @@ common =
setfast v = Annex.changeState $ \s -> s { Annex.fast = v } setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
setauto v = Annex.changeState $ \s -> s { Annex.auto = v } setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
setdebug = liftIO $ do setdebug = liftIO $ updateGlobalLogger rootLoggerName $ setLevel DEBUG
s <- simpledebug
updateGlobalLogger rootLoggerName
(setLevel DEBUG . setHandlers [s])
simpledebug = setFormatter
<$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg")
matcher :: [Option] matcher :: [Option]
matcher = matcher =