{-# 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