module System.Wlog.Handler.Simple
( streamHandler
, fileHandler
, GenericHandler(..)
, verboseStreamHandler
) where
import Control.Exception (SomeException)
import Data.Maybe (fromMaybe)
import qualified Data.Text.IO as TIO
import Data.Typeable (Typeable)
import System.IO (hClose, hFlush)
import Universum
import System.Wlog.Formatter (LogFormatter, nullFormatter, simpleLogFormatter)
import System.Wlog.Handler (LogHandler (..))
import System.Wlog.Severity (Severity (..))
data GenericHandler a = GenericHandler
{ severity :: Severity
, formatter :: LogFormatter (GenericHandler a)
, privData :: a
, writeFunc :: a -> Text -> IO ()
, closeFunc :: a -> IO ()
, ghTag :: Maybe String
} deriving Typeable
instance Typeable a => LogHandler (GenericHandler a) where
getTag = fromMaybe "GenericHandler" . ghTag
setLevel sh s = sh {severity = s}
getLevel sh = severity sh
setFormatter sh f = sh{formatter = f}
getFormatter sh = formatter sh
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 ()
let mywritefunc hdl msg =
withMVar lock (const $ writeToHandle hdl msg >> hFlush hdl)
return
GenericHandler
{ severity = sev
, formatter = nullFormatter
, privData = h
, writeFunc = mywritefunc
, closeFunc = const $ pure ()
, ghTag = Just "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 AppendMode
sh <- streamHandler h sev
return (sh {closeFunc = hClose, ghTag = Just ("fileHandler:" ++ 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