module System.FastLogger
( Logger
, timestampedLogEntry
, combinedLogEntry
, newLogger
, logMsg
, stopLogger
) where
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Control.Concurrent
import Control.Exception
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Internal (c2w)
import Data.Int
import Data.IORef
import Data.Monoid
import System.IO
import Snap.Internal.Http.Server.Date
data Logger = Logger
{ _queuedMessages :: !(IORef Builder)
, _dataWaiting :: !(MVar ())
, _loggerPath :: !(FilePath)
, _loggingThread :: !(MVar ThreadId) }
newLogger :: FilePath -> IO Logger
newLogger fp = do
q <- newIORef mempty
dw <- newEmptyMVar
th <- newEmptyMVar
let lg = Logger q dw fp th
tid <- forkIO $ loggingThread lg
putMVar th tid
return lg
timestampedLogEntry :: ByteString -> IO ByteString
timestampedLogEntry msg = do
timeStr <- getLogDateString
return $! toByteString
$! mconcat [ fromWord8 $ c2w '['
, fromByteString timeStr
, fromByteString "] "
, fromByteString msg ]
combinedLogEntry :: ByteString
-> Maybe ByteString
-> ByteString
-> Int
-> Maybe Int64
-> Maybe ByteString
-> ByteString
-> IO ByteString
combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !ua = do
timeStr <- getLogDateString
let !l = [ fromByteString host
, fromByteString " - "
, user
, fromByteString " ["
, fromByteString timeStr
, fromByteString "] \""
, fromByteString req
, fromByteString "\" "
, fromShow status
, space
, numBytes
, space
, referer
, fromByteString " \""
, fromByteString ua
, quote ]
let !output = toByteString $ mconcat l
return $! output
where
dash = fromWord8 $ c2w '-'
quote = fromWord8 $ c2w '\"'
space = fromWord8 $ c2w ' '
user = maybe dash fromByteString mbUser
numBytes = maybe dash fromShow mbNumBytes
referer = maybe dash
(\s -> mconcat [ quote
, fromByteString s
, quote ])
mbReferer
logMsg :: Logger -> ByteString -> IO ()
logMsg !lg !s = do
let !s' = fromByteString s `mappend` (fromWord8 $ c2w '\n')
atomicModifyIORef (_queuedMessages lg) $ \d -> (d `mappend` s',())
tryPutMVar (_dataWaiting lg) () >> return ()
loggingThread :: Logger -> IO ()
loggingThread (Logger queue notifier filePath _) = do
initialize >>= go
where
openIt = if filePath == "-"
then return stdout
else if filePath == "stderr"
then return stderr
else openFile filePath AppendMode
closeIt h = if filePath == "-" || filePath == "stderr"
then return ()
else hClose h
go (href, lastOpened) =
(loop (href, lastOpened))
`catches`
[ Handler $ \(_::AsyncException) -> killit (href, lastOpened)
, Handler $ \(e::SomeException) -> do
hPutStrLn stderr $ "logger got exception: " ++ Prelude.show e
threadDelay 20000000
go (href, lastOpened) ]
initialize = do
lh <- openIt
href <- newIORef lh
t <- getCurrentDateTime
tref <- newIORef t
return (href, tref)
killit (href, lastOpened) = do
flushIt (href, lastOpened)
h <- readIORef href
closeIt h
flushIt (!href, !lastOpened) = do
dl <- atomicModifyIORef queue $ \x -> (mempty,x)
let !msgs = toLazyByteString dl
h <- readIORef href
L.hPut h msgs
hFlush h
t <- getCurrentDateTime
old <- readIORef lastOpened
if told > 900
then do
closeIt h
openIt >>= writeIORef href
writeIORef lastOpened t
else return ()
loop !d = do
_ <- takeMVar notifier
flushIt d
threadDelay 5000000
loop d
stopLogger :: Logger -> IO ()
stopLogger lg = withMVar (_loggingThread lg) killThread