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, master has been updated
via 9cb10b8cfb65e0f0c3316d65cdd1022f178c2df1 (commit)
via c4186d7352f394893307e7712783d9c5df413b14 (commit)
via d4adf2f5048f198873648ca0e3ce9bf05caff464 (commit)
from b71b0cdac729bfc5fb8b3fc3463c371590437a93 (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 6 ++-
src/Snap/Internal/Http/Server/Date.hs | 64 +++++++++++++++++--------
src/Snap/Internal/Http/Server/LibevBackend.hs | 2 +-
3 files changed, 48 insertions(+), 24 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 9cb10b8cfb65e0f0c3316d65cdd1022f178c2df1
Author: Gregory Collins <[email protected]>
Date: Sat Aug 28 18:50:26 2010 -0400
Fix mapM_ issue in libev backend
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index c243e17..abf1d14 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -436,7 +436,7 @@ freeBackend backend = ignoreException $ block $ do
-- kill everything in thread table
tset <- H.toList $ _connectionThreads backend
- mapM_ (killThread . fst) tset
+ Prelude.mapM_ (killThread . fst) tset
debug $ "Backend.freeBackend: all threads killed"
debug $ "Backend.freeBackend: destroying resources"
commit c4186d7352f394893307e7712783d9c5df413b14
Author: Gregory Collins <[email protected]>
Date: Sat Aug 28 13:33:23 2010 -0400
Attempt to fix error.log spam bug in simple backend
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 78fafc9..f60e857 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -127,8 +127,10 @@ httpServe bindAddress bindPort localHostname alogPath
elogPath handler =
--------------------------------------------------------------------------
runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do
- Prelude.mapM_ f $ xs `zip` [0..]
- Prelude.mapM_ (takeMVar . snd) xs
+ tids <- Prelude.mapM f $ xs `zip` [0..]
+ Prelude.mapM_ (takeMVar . snd) xs `catch` \ (e::SomeException) -> do
+ mapM killThread tids
+ throwIO e
where
f ((backend,mvar),cpu) = forkOnIO cpu $ do
labelMe $ map w2c $ S.unpack $
commit d4adf2f5048f198873648ca0e3ce9bf05caff464
Author: Gregory Collins <[email protected]>
Date: Sat Aug 28 13:21:07 2010 -0400
Tweaks to date thread to prevent blocking when computing current time
diff --git a/src/Snap/Internal/Http/Server/Date.hs
b/src/Snap/Internal/Http/Server/Date.hs
index 6d9b371..f2ca25c 100644
--- a/src/Snap/Internal/Http/Server/Date.hs
+++ b/src/Snap/Internal/Http/Server/Date.hs
@@ -11,6 +11,7 @@ import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import Data.IORef
+import Data.Maybe
import Foreign.C.Types
import System.IO.Unsafe
@@ -31,16 +32,18 @@ import Snap.Internal.Http.Types (formatHttpTime,
formatLogTime)
-- running the computation on a timer. We'll allow client traffic to trigger
-- the process.
+------------------------------------------------------------------------------
data DateState = DateState {
_cachedDateString :: !(IORef ByteString)
, _cachedLogString :: !(IORef ByteString)
, _cachedDate :: !(IORef CTime)
, _valueIsOld :: !(IORef Bool)
, _morePlease :: !(MVar ())
- , _dataAvailable :: !(MVar ())
, _dateThread :: !(MVar ThreadId)
}
+
+------------------------------------------------------------------------------
dateState :: DateState
dateState = unsafePerformIO $ do
(s1,s2,date) <- fetchTime
@@ -50,9 +53,8 @@ dateState = unsafePerformIO $ do
ov <- newIORef False
th <- newEmptyMVar
mp <- newMVar ()
- da <- newMVar ()
- let d = DateState bs1 bs2 dt ov mp da th
+ let d = DateState bs1 bs2 dt ov mp th
t <- forkIO $ dateThread d
putMVar th t
@@ -61,6 +63,7 @@ dateState = unsafePerformIO $ do
#ifdef PORTABLE
+------------------------------------------------------------------------------
epochTime :: IO CTime
epochTime = do
t <- getPOSIXTime
@@ -68,6 +71,7 @@ epochTime = do
#endif
+------------------------------------------------------------------------------
fetchTime :: IO (ByteString,ByteString,CTime)
fetchTime = do
now <- epochTime
@@ -76,48 +80,66 @@ fetchTime = do
return (t1, t2, now)
-dateThread :: DateState -> IO ()
-dateThread ds@(DateState dateString logString time valueIsOld morePlease
- dataAvailable _) = do
- -- a lot of effort to make sure we don't deadlock
- takeMVar morePlease
-
+------------------------------------------------------------------------------
+updateState :: DateState -> IO ()
+updateState (DateState dateString logString time valueIsOld _ _) = do
(s1,s2,now) <- fetchTime
atomicModifyIORef dateString $ const (s1,())
- atomicModifyIORef logString $ const (s2,())
- atomicModifyIORef time $ const (now,())
-
+ atomicModifyIORef logString $ const (s2,())
+ atomicModifyIORef time $ const (now,())
writeIORef valueIsOld False
- tryPutMVar dataAvailable ()
- threadDelay 2000000
+ -- force values in the iorefs to prevent thunk buildup
+ !_ <- readIORef dateString
+ !_ <- readIORef logString
+ !_ <- readIORef time
+
+ return ()
- takeMVar dataAvailable
- writeIORef valueIsOld True
- dateThread ds
+------------------------------------------------------------------------------
+dateThread :: DateState -> IO ()
+dateThread ds@(DateState _ _ _ valueIsOld morePlease _) = loop
+ where
+ loop = do
+ b <- tryTakeMVar morePlease
+ when (isNothing b) $ do
+ writeIORef valueIsOld True
+ takeMVar morePlease
+ updateState ds
+ threadDelay 2000000
+ loop
+
+
+------------------------------------------------------------------------------
ensureFreshDate :: IO ()
ensureFreshDate = block $ do
old <- readIORef $ _valueIsOld dateState
- when old $ do
- tryPutMVar (_morePlease dateState) ()
- readMVar $ _dataAvailable dateState
+ tryPutMVar (_morePlease dateState) ()
+
+ -- if the value is not fresh we will tickle the date thread but also fetch
+ -- the new value immediately; we used to block but we'll do a little extra
+ -- work to avoid a delay
+ when old $ updateState dateState
+
+------------------------------------------------------------------------------
getDateString :: IO ByteString
getDateString = block $ do
ensureFreshDate
readIORef $ _cachedDateString dateState
+------------------------------------------------------------------------------
getLogDateString :: IO ByteString
getLogDateString = block $ do
ensureFreshDate
readIORef $ _cachedLogString dateState
+------------------------------------------------------------------------------
getCurrentDateTime :: IO CTime
getCurrentDateTime = block $ do
ensureFreshDate
readIORef $ _cachedDate dateState
-
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
