From 677576955a708ed543d9d7c21d520cfceced3428 Mon Sep 17 00:00:00 2001 From: Mighty Byte Date: Wed, 27 Oct 2010 20:17:41 -0400 Subject: [PATCH] Undo attempt at speeding up FastLogger. --- src/System/FastLogger.hs | 145 ++++++++++++--------------------------- 1 file changed, 42 insertions(+), 103 deletions(-) diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs index 3cc6ecdb..2de0c7a8 100644 --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -14,87 +14,27 @@ module System.FastLogger import Control.Concurrent import Control.Exception import Control.Monad -import Data.Binary.Put -import Data.Bits import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Internal (c2w) import Data.DList (DList) import qualified Data.DList as D -import Data.Function import Data.Int import Data.IORef import Data.Maybe -import Data.Ord -import qualified Data.Vector as V -import Data.Vector (Vector) -import qualified Data.Vector.Algorithms.Merge as VA -import Data.Word -import Foreign.C.Types (CTime) -import GHC.Conc (numCapabilities) +import Data.Serialize.Put import Prelude hiding (catch, show) import qualified Prelude import System.IO -import Text.Show.ByteString +import Text.Show.ByteString hiding (runPut) ------------------------------------------------------------------------------- -import Data.Concurrent.HashMap (hashString, nextHighestPowerOf2) import Snap.Internal.Http.Server.Date ------------------------------------------------------------------------------- -defaultNumberOfLocks :: Word -defaultNumberOfLocks = nextHighestPowerOf2 $ toEnum $ 4 * numCapabilities - ------------------------------------------------------------------------------- -hashToBucket :: Word -> Word -hashToBucket x = x .&. (defaultNumberOfLocks-1) - - ------------------------------------------------------------------------------- -type Queue = DList (CTime, ByteString) - -newtype MessageBuffer = MessageBuffer { - _queues :: Vector (MVar Queue) -} - ------------------------------------------------------------------------------- -newMessageBuffer :: IO MessageBuffer -newMessageBuffer = liftM MessageBuffer $ - V.replicateM (fromEnum defaultNumberOfLocks) (newMVar D.empty) - - -getAllMessages :: MessageBuffer -> IO (Vector ByteString) -getAllMessages (MessageBuffer queues) = do - vec <- liftM (V.concat . V.toList) $ V.mapM grabQ queues - mvec <- V.unsafeThaw vec - - -- sort the list so the messages are emitted in time order - VA.sortBy cmp mvec - dvec <- V.unsafeFreeze mvec - return $ V.map snd dvec - - where - grabQ mv = modifyMVar mv $ \q -> return (D.empty, V.fromList $ D.toList q) - cmp = compare `on` fst - - -addMessageToQueue :: MVar Queue -> CTime -> ByteString -> IO () -addMessageToQueue mv tm s = modifyMVar_ mv $ \q -> return $ D.snoc q (tm,s) - - -addMessage :: MessageBuffer -> CTime -> ByteString -> IO () -addMessage (MessageBuffer queues) tm !s = do - tid <- myThreadId - let hash = hashString $ Prelude.show tid - let bucket = hashToBucket hash - let mv = V.unsafeIndex queues $ fromEnum bucket - addMessageToQueue mv tm s - - -- | Holds the state for a logger. data Logger = Logger - { _queuedMessages :: !MessageBuffer + { _queuedMessages :: !(IORef (DList ByteString)) , _dataWaiting :: !(MVar ()) , _loggerPath :: !(FilePath) , _loggingThread :: !(MVar ThreadId) } @@ -106,25 +46,24 @@ data Logger = Logger -- re-opened every 15 minutes to facilitate external log rotation. newLogger :: FilePath -> IO Logger newLogger fp = do - mb <- newMessageBuffer + q <- newIORef D.empty dw <- newEmptyMVar th <- newEmptyMVar - let lg = Logger mb dw fp th + let lg = Logger q dw fp th tid <- forkIO $ loggingThread lg putMVar th tid return lg - -- | Prepares a log message with the time prepended. timestampedLogEntry :: ByteString -> IO ByteString timestampedLogEntry msg = do timeStr <- getLogDateString - return $! S.concat $! L.toChunks $! runPut $! do - putAscii '[' + return $! runPut $! do + putWord8 $ c2w '[' putByteString timeStr putByteString "] " putByteString msg @@ -144,29 +83,35 @@ combinedLogEntry :: ByteString -- ^ remote host -> IO ByteString combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent = do let user = fromMaybe "-" mbUser + let numBytes = maybe "-" (\s -> strict $ show s) mbNumBytes let referer = maybe "-" (\s -> S.concat ["\"", s, "\""]) mbReferer timeStr <- getLogDateString - return $ S.concat $ L.toChunks $ runPut $ do - putByteString host - putByteString " - " - putByteString user - putByteString " [" - putByteString timeStr - putByteString "] \"" - putByteString req - putByteString "\" " - showp status - putAscii ' ' - maybe (putAscii '-') - (showp) - mbNumBytes - putAscii ' ' - putByteString referer - putByteString " \"" - putByteString userAgent - putAscii '\"' + let !p = [ host + , " - " + , user + , " [" + , timeStr + , "] \"" + , req + , "\" " + , strict $ show status + , " " + , numBytes + , " " + , referer + , " \"" + , userAgent + , "\"" ] + + let !output = S.concat p + + return $! output + + + where + strict = S.concat . L.toChunks -- | Sends out a log message verbatim with a newline appended. Note: @@ -175,8 +120,7 @@ combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent = logMsg :: Logger -> ByteString -> IO () logMsg !lg !s = do let !s' = S.snoc s '\n' - tm <- getCurrentDateTime - addMessage (_queuedMessages lg) tm s' + atomicModifyIORef (_queuedMessages lg) $ \d -> (D.snoc d s',()) tryPutMVar (_dataWaiting lg) () >> return () @@ -185,22 +129,16 @@ loggingThread (Logger queue notifier filePath _) = do initialize >>= go where - -------------------------------------------------------------------------- openIt = if filePath == "-" then return stdout else if filePath == "stderr" then return stderr - else do - h <- openFile filePath AppendMode - hSetBuffering h $ BlockBuffering $ Just 32768 - return h + else openFile filePath AppendMode - -------------------------------------------------------------------------- closeIt h = if filePath == "-" || filePath == "stderr" then return () else hClose h - -------------------------------------------------------------------------- go (href, lastOpened) = (loop (href, lastOpened)) `catches` @@ -210,7 +148,7 @@ loggingThread (Logger queue notifier filePath _) = do threadDelay 20000000 go (href, lastOpened) ] - -------------------------------------------------------------------------- + initialize = do lh <- openIt href <- newIORef lh @@ -218,19 +156,20 @@ loggingThread (Logger queue notifier filePath _) = do tref <- newIORef t return (href, tref) - -------------------------------------------------------------------------- + killit (href, lastOpened) = do flushIt (href, lastOpened) h <- readIORef href closeIt h - -------------------------------------------------------------------------- + flushIt (!href, !lastOpened) = do - msgs <- getAllMessages queue + dl <- atomicModifyIORef queue $ \x -> (D.empty,x) - -- flush all messages out to buffer + let !msgs = D.toList dl + let !s = L.fromChunks msgs h <- readIORef href - V.mapM_ (S.hPut h) msgs + L.hPut h s hFlush h -- close the file every 15 minutes (for log rotation)