module System.Wlog.Handler.Simple
( streamHandler
, fileHandler
, GenericHandler(..)
, verboseStreamHandler
) where
import Control.Concurrent (modifyMVar_, withMVar)
import Control.Exception (SomeException)
import qualified Data.Text.IO as TIO
import Data.Typeable (Typeable)
import System.IO (Handle, IOMode (ReadWriteMode),
SeekMode (SeekFromEnd), hClose, hFlush, hSeek)
import Universum
import System.Wlog.Formatter (LogFormatter, nullFormatter, simpleLogFormatter)
import System.Wlog.Handler (LogHandler (..), LogHandlerTag (..))
import System.Wlog.MemoryQueue (MemoryQueue)
import System.Wlog.MemoryQueue as MQ
import System.Wlog.Severity (Severity (..))
data GenericHandler a = GenericHandler
{ severity :: !Severity
, formatter :: !(LogFormatter (GenericHandler a))
, privData :: !a
, writeFunc :: !(a -> Text -> IO ())
, closeFunc :: !(a -> IO ())
, readBackBuffer :: !(MVar (MemoryQueue Text))
, ghTag :: !LogHandlerTag
} deriving Typeable
instance Typeable a => LogHandler (GenericHandler a) where
getTag = ghTag
setLevel sh s = sh {severity = s}
getLevel sh = severity sh
setFormatter sh f = sh{formatter = f}
getFormatter sh = formatter sh
readBack sh i = withMVar (readBackBuffer sh) $ pure . take i . MQ.toList
emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg
close sh = (closeFunc sh) (privData sh)
streamHandler :: Handle -> Severity -> IO (GenericHandler Handle)
streamHandler h sev = do
lock <- newMVar ()
mq <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024
let mywritefunc hdl msg = withMVar lock $ const $ do
writeToHandle hdl msg
modifyMVar_ mq $ pure . pushFront msg
hFlush hdl
return
GenericHandler
{ severity = sev
, formatter = nullFormatter
, privData = h
, writeFunc = mywritefunc
, closeFunc = const $ pure ()
, readBackBuffer = mq
, ghTag = HandlerOther "GenericHandler/StreamHandler"
}
where
writeToHandle hdl msg =
TIO.hPutStrLn hdl msg `catch` (handleWriteException hdl msg)
handleWriteException :: Handle -> Text -> SomeException -> IO ()
handleWriteException hdl msg e =
let msg' =
"Error writing log message: " <>
show e <> " (original message: " <> msg <> ")"
in TIO.hPutStrLn hdl msg'
fileHandler :: FilePath -> Severity -> IO (GenericHandler Handle)
fileHandler fp sev = do
h <- openFile fp ReadWriteMode
hSeek h SeekFromEnd 0
sh <- streamHandler h sev
pure $ sh { closeFunc = hClose
, ghTag = HandlerFilelike fp
}
verboseStreamHandler :: Handle -> Severity -> IO (GenericHandler Handle)
verboseStreamHandler h sev =
let fmt = simpleLogFormatter "[$loggername/$prio] $msg"
in do hndlr <- streamHandler h sev
return $ setFormatter hndlr fmt