module Yesod.Logger
( Logger
, makeLogger
, flushLogger
, timed
, logText
, logLazyText
, logString
) where
import Control.Monad (forever)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan)
import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar)
import Text.Printf (printf)
import Data.Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO
import Data.Time (getCurrentTime, diffUTCTime)
data Logger = Logger
{ loggerChan :: Chan (Maybe TL.Text)
, loggerSync :: MVar ()
}
makeLogger :: IO Logger
makeLogger = do
logger <- Logger <$> newChan <*> newEmptyMVar
_ <- forkIO $ loggerThread logger
return logger
where
loggerThread logger = forever $ do
msg <- readChan $ loggerChan logger
case msg of
Nothing -> putMVar (loggerSync logger) ()
Just m -> Data.Text.Lazy.IO.putStrLn m
flushLogger :: Logger -> IO ()
flushLogger logger = do
writeChan (loggerChan logger) Nothing
() <- takeMVar $ loggerSync logger
return ()
logLazyText :: Logger -> TL.Text -> IO ()
logLazyText logger = writeChan (loggerChan logger) . Just
logText :: Logger -> Text -> IO ()
logText logger = logLazyText logger . TL.fromStrict
logString :: Logger -> String -> IO ()
logString logger = logLazyText logger . TL.pack
timed :: MonadIO m
=> Logger
-> Text
-> m a
-> m a
timed logger msg action = do
start <- liftIO getCurrentTime
!result <- action
stop <- liftIO getCurrentTime
let diff = fromEnum $ diffUTCTime stop start
ms = diff `div` 10 ^ (9 :: Int)
formatted = printf " [%4dms] %s" ms (unpack msg)
liftIO $ logString logger formatted
return result