This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, 0.2-stable has been updated
via 677576955a708ed543d9d7c21d520cfceced3428 (commit)
from 148f2d54cfdca0667cebf7f32d5e3e3421e0bbc7 (commit)
Summary of changes:
src/System/FastLogger.hs | 145 +++++++++++++--------------------------------
1 files changed, 42 insertions(+), 103 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 677576955a708ed543d9d7c21d520cfceced3428
Author: Mighty Byte <[email protected]>
Date: Wed Oct 27 20:17:41 2010 -0400
Undo attempt at speeding up FastLogger.
diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs
index 3cc6ecd..2de0c7a 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)
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
