{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module System.Wlog.LogHandler.Simple
( GenericHandler(..)
, defaultHandleAction
, fileHandler
, streamHandler
) where
import Universum
import Control.Concurrent (modifyMVar_, withMVar)
import Data.Text.Lazy.Builder as B
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.IO (SeekMode (SeekFromEnd), hFlush, hSeek)
import System.Wlog.Formatter (LogFormatter, nullFormatter)
import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (..))
import System.Wlog.MemoryQueue (MemoryQueue, newMemoryQueue, pushFront, queueToList)
import System.Wlog.Severity (Severities)
import qualified Data.Text.IO as TIO
data GenericHandler a = GenericHandler
{ severities :: !Severities
, 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 {severities = s}
getLevel = severities
setFormatter sh f = sh{formatter = f}
getFormatter = formatter
readBack sh i = liftIO $ withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . queueToList $ mq'
emit sh bldr _ = liftIO $ writeFunc sh (privData sh) (toText . B.toLazyText $ bldr)
close sh = liftIO $ closeFunc sh (privData sh)
defaultHandleAction :: Handle -> Text -> IO ()
defaultHandleAction = TIO.hPutStrLn
createWriteFuncWrapper
:: (Handle -> Text -> IO ())
-> MVar ()
-> IO ( Handle -> Text -> IO ()
, MVar (MemoryQueue Text)
)
createWriteFuncWrapper action lock = do
memoryQueue <- newMVar $ 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 ()
-> Severities
-> IO (GenericHandler Handle)
streamHandler privData writeAction lock severities = do
(writeFunc, readBackBuffer) <- createWriteFuncWrapper writeAction lock
return GenericHandler
{ formatter = nullFormatter
, closeFunc = const $ pure ()
, ghTag = HandlerOther "GenericHandler/StreamHandler"
, ..
}
fileHandler :: FilePath -> Severities -> 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
}