Permalink
Fetching contributors…
Cannot retrieve contributors at this time
284 lines (237 sloc) 11.1 KB
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.FastLogger
( Logger
, timestampedLogEntry
, combinedLogEntry
, newLogger
, newLoggerWithCustomErrorFunction
, withLogger
, withLoggerWithCustomErrorFunction
, stopLogger
, logMsg
) where
------------------------------------------------------------------------------
import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar, withMVar)
import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs)
import Control.Exception (AsyncException, Handler (..), IOException, SomeException, bracket, catch, catches, mask_)
import Control.Monad (unless, void, when)
import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString, toLazyByteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Monoid (mappend, mconcat, mempty)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word (Word64)
import Prelude (Eq (..), FilePath, IO, Int, Maybe, Monad (..), Num (..), Ord (..), Show (..), mapM_, maybe, ($), ($!), (++), (.), (||))
import System.IO (IOMode (AppendMode), hClose, hFlush, openFile, stderr, stdout)
import System.PosixCompat.Time (epochTime)
------------------------------------------------------------------------------
import Snap.Internal.Http.Server.Common (atomicModifyIORef')
import Snap.Internal.Http.Server.Date (getLogDateString)
------------------------------------------------------------------------------
-- | Holds the state for a logger.
data Logger = Logger
{ _queuedMessages :: !(IORef Builder)
, _dataWaiting :: !(MVar ())
, _loggerPath :: !(FilePath)
, _loggingThread :: !(MVar ThreadId)
, _errAction :: ByteString -> IO ()
}
------------------------------------------------------------------------------
-- | Creates a new logger, logging to the given file. If the file argument is
-- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr,
-- otherwise we log to a regular file in append mode. The file is closed and
-- re-opened every 15 minutes to facilitate external log rotation.
newLogger :: FilePath -- ^ log file to use
-> IO Logger
newLogger = newLoggerWithCustomErrorFunction
(\s -> S.hPutStr stderr s >> hFlush stderr)
------------------------------------------------------------------------------
-- | Like 'newLogger', but uses a custom error action if the logger needs to
-- print an error message of its own (for instance, if it can't open the
-- output file.)
newLoggerWithCustomErrorFunction :: (ByteString -> IO ())
-- ^ logger uses this action to log any
-- error messages of its own
-> FilePath -- ^ log file to use
-> IO Logger
newLoggerWithCustomErrorFunction errAction fp = do
q <- newIORef mempty
dw <- newEmptyMVar
th <- newEmptyMVar
let lg = Logger q dw fp th errAction
mask_ $ do
tid <- forkIOLabeledWithUnmaskBs "snap-server: logging" $
loggingThread lg
putMVar th tid
return lg
------------------------------------------------------------------------------
-- | Creates a Logger and passes it into the given function, cleaning up
-- with \"stopLogger\" afterwards.
withLogger :: FilePath -- ^ log file to use
-> (Logger -> IO a)
-> IO a
withLogger f = bracket (newLogger f) stopLogger
------------------------------------------------------------------------------
-- | Creates a Logger with \"newLoggerWithCustomErrorFunction\" and passes it
-- into the given function, cleaning up with \"stopLogger\" afterwards.
withLoggerWithCustomErrorFunction :: (ByteString -> IO ())
-- ^ logger uses this action to log any
-- error messages of its own
-> FilePath -- ^ log file to use
-> (Logger -> IO a)
-> IO a
withLoggerWithCustomErrorFunction e f =
bracket (newLoggerWithCustomErrorFunction e f) stopLogger
------------------------------------------------------------------------------
-- FIXME: can be a builder, and we could even use the same trick we use for
-- HTTP
--
-- | Prepares a log message with the time prepended.
timestampedLogEntry :: ByteString -> IO ByteString
timestampedLogEntry msg = do
timeStr <- getLogDateString
return $! S.concat
$ L.toChunks
$ toLazyByteString
$ mconcat [ char8 '['
, byteString timeStr
, byteString "] "
, byteString msg ]
------------------------------------------------------------------------------
-- FIXME: builder
--
-- | Prepares a log message in \"combined\" format.
combinedLogEntry :: ByteString -- ^ remote host
-> Maybe ByteString -- ^ remote user
-> ByteString -- ^ request line (up to you to ensure
-- there are no quotes in here)
-> Int -- ^ status code
-> Word64 -- ^ num bytes sent
-> Maybe ByteString -- ^ referer (up to you to ensure
-- there are no quotes in here)
-> ByteString -- ^ user agent (up to you to ensure
-- there are no quotes in here)
-> IO ByteString
combinedLogEntry !host !mbUser !req !status !numBytes !mbReferer !ua = do
timeStr <- getLogDateString
let !l = [ byteString host
, byteString " - "
, user
, byteString " ["
, byteString timeStr
, byteString "] \""
, byteString req
, byteString "\" "
, fromShow status
, space
, fromShow numBytes
, space
, referer
, byteString " \""
, byteString ua
, quote ]
return $! S.concat . L.toChunks $ toLazyByteString $ mconcat l
where
dash = char8 '-'
quote = char8 '\"'
space = char8 ' '
user = maybe dash byteString mbUser
referer = maybe dash
(\s -> mconcat [ quote
, byteString s
, quote ])
mbReferer
------------------------------------------------------------------------------
-- | Sends out a log message verbatim with a newline appended. Note:
-- if you want a fancy log message you'll have to format it yourself
-- (or use 'combinedLogEntry').
logMsg :: Logger -> ByteString -> IO ()
logMsg !lg !s = do
let !s' = byteString s `mappend` char8 '\n'
atomicModifyIORef' (_queuedMessages lg) $ \d -> (d `mappend` s',())
void $ tryPutMVar (_dataWaiting lg) ()
------------------------------------------------------------------------------
loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
loggingThread (Logger queue notifier filePath _ errAct) unmask = do
initialize >>= go
where
openIt =
if filePath == "-"
then return stdout
else
if filePath == "stderr"
then return stderr
else openFile filePath AppendMode `catch`
\(e::IOException) -> do
logInternalError $ "Can't open log file \"" ++
filePath ++ "\".\n"
logInternalError $ "Exception: " ++ show e ++ "\n"
logInternalError $ "Logging to stderr instead. " ++
"**THIS IS BAD, YOU OUGHT TO " ++
"FIX THIS**\n\n"
return stderr
closeIt h = unless (h == stdout || h == stderr) $
hClose h
logInternalError = errAct . T.encodeUtf8 . T.pack
--------------------------------------------------------------------------
go (href, lastOpened) = unmask loop `catches`
[ Handler $ \(_::AsyncException) -> killit (href, lastOpened)
, Handler $ \(e::SomeException) -> do
logInternalError $ "logger got exception: "
++ Prelude.show e ++ "\n"
threadDelay 20000000
go (href, lastOpened) ]
where
loop = waitFlushDelay (href, lastOpened) >> loop
--------------------------------------------------------------------------
initialize = do
lh <- openIt
href <- newIORef lh
t <- epochTime
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
(do L.hPut h msgs
hFlush h) `catch` \(e::IOException) -> do
logInternalError $ "got exception writing to log " ++
filePath ++ ": " ++ show e ++ "\n"
logInternalError "writing log entries to stderr.\n"
mapM_ errAct $ L.toChunks msgs
-- close the file every 15 minutes (for log rotation)
t <- epochTime
old <- readIORef lastOpened
when (t-old > 900) $ do
closeIt h
mask_ $ openIt >>= writeIORef href
writeIORef lastOpened t
waitFlushDelay !d = do
-- wait on the notification mvar
_ <- takeMVar notifier
-- grab the queued messages and write them out
flushIt d
-- at least five seconds between log dumps
threadDelay 5000000
------------------------------------------------------------------------------
-- | Kills a logger thread, causing any unwritten contents to be
-- flushed out to disk
stopLogger :: Logger -> IO ()
stopLogger lg = withMVar (_loggingThread lg) killThread
------------------------------------------------------------------------------
fromShow :: Show a => a -> Builder
fromShow = stringUtf8 . show