module System.Wlog.Handler.Simple
( GenericHandler(..)
, defaultHandleAction
, fileHandler
, streamHandler
) 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)
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)
defaultHandleAction :: Handle -> Text -> IO ()
defaultHandleAction h message =
TIO.hPutStrLn h message `catch` handleWriteException
where
handleWriteException :: SomeException -> IO ()
handleWriteException e = do
let errorMessage = "Error writing log message: "
<> show e <> " (original message: " <> message <> ")"
TIO.hPutStrLn h errorMessage
createWriteFuncWrapper
:: (Handle -> Text -> IO ())
-> MVar ()
-> IO ( Handle -> Text -> IO ()
, MVar (MemoryQueue Text)
)
createWriteFuncWrapper action lock = do
memoryQueue <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024
let customWriteFunc :: Handle -> Text -> IO ()
customWriteFunc hdl msg = withMVar lock $ const $ do
action hdl msg
modifyMVar_ memoryQueue $ \mq -> pure $! pushFront msg mq
hFlush hdl
return (customWriteFunc, memoryQueue)
streamHandler :: Handle
-> (Handle -> Text -> IO ())
-> MVar ()
-> Severity
-> IO (GenericHandler Handle)
streamHandler privData writeAction lock severity = do
(writeFunc, readBackBuffer) <- createWriteFuncWrapper writeAction lock
return GenericHandler
{ formatter = nullFormatter
, closeFunc = const $ pure ()
, ghTag = HandlerOther "GenericHandler/StreamHandler"
, ..
}
fileHandler :: FilePath -> Severity -> IO (GenericHandler Handle)
fileHandler fp sev = do
createDirectoryIfMissing True (takeDirectory fp)
h <- openFile fp ReadWriteMode
hSeek h SeekFromEnd 0
lock <- newMVar ()
sh <- streamHandler h defaultHandleAction lock sev
pure $ sh { closeFunc = hClose
, ghTag = HandlerFilelike fp
}