module SecondTransfer.MainLoop.Logging (
enableConsoleLogging
,logWithExclusivity
,logit
) where
import System.IO (stderr,openFile)
import qualified System.IO as SIO
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Bch
import System.Log.Formatter (simpleLogFormatter)
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import System.Log.Logger
import System.IO.Unsafe (unsafePerformIO)
import System.Clock as Cl
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Concurrent
enableConsoleLogging :: IO ()
enableConsoleLogging = configureLoggingToConsole
globallyLogWell :: MVar ()
globallyLogWell = unsafePerformIO (newMVar () )
logWithExclusivity :: IO () -> IO ()
logWithExclusivity a = withMVar globallyLogWell (const a )
configureLoggingToConsole :: IO ()
configureLoggingToConsole = do
s <- streamHandler stderr DEBUG >>=
\lh -> return $ setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg")
setLoggerLevels s
setLoggerLevels :: (LogHandler s) => s -> IO ()
setLoggerLevels s = do
updateGlobalLogger rootLoggerName removeHandler
updateGlobalLogger "Session" (
setHandlers [s] .
setLevel INFO
)
updateGlobalLogger "OpenSSL" (
setHandlers [s] .
setLevel DEBUG
)
updateGlobalLogger "HTTP1" (
setHandlers [s] .
setLevel DEBUG
)
updateGlobalLogger "HTTP2" (
setHandlers [s] .
setLevel DEBUG
)
data Logit = Logit Cl.TimeSpec B.ByteString
loggerChan :: Chan Logit
loggerChan = unsafePerformIO $ do
chan <- newChan
log_file <- openFile "LOGIT" SIO.WriteMode
SIO.hSetBuffering log_file SIO.LineBuffering
start_of_time <- Cl.getTime Cl.Monotonic
forkIO $ readLoggerChan chan log_file start_of_time
return chan
readLoggerChan :: Chan Logit -> SIO.Handle -> Cl.TimeSpec -> IO ()
readLoggerChan chan_logit file_handle origin_time = do
Logit timespec bs <- readChan chan_logit
let
Cl.TimeSpec sec' nsec' = timespec origin_time
SIO.hPutStr file_handle (show sec')
SIO.hPutStr file_handle "|"
SIO.hPutStr file_handle (show nsec')
SIO.hPutStr file_handle "|"
Bch.hPutStrLn file_handle bs
SIO.hFlush file_handle
readLoggerChan chan_logit file_handle origin_time
logit :: B.ByteString -> IO ()
logit !msg = do
time <- Cl.getTime Cl.Monotonic
let
lg = Logit time msg
writeChan loggerChan lg