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.Text.Lazy.Builder as B
import Data.Typeable (Typeable)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
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) $ \mq' -> pure $! take i . MQ.toList $ mq'
emit sh bldr _ = (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr)
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 $ \mq' -> pure $! pushFront msg mq'
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
createDirectoryIfMissing True (takeDirectory fp)
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