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 53cf92232ff69c6dea4b3ffc8d6d7f59a354afeb (commit)
from bf50ce5ed3c8f612444124ad851295c82a20a2ff (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 3 +-
src/Snap/Internal/Http/Server/LibevBackend.hs | 53 +++++++-----------------
src/Snap/Internal/Http/Server/SimpleBackend.hs | 38 ++++++++++++-----
3 files changed, 42 insertions(+), 52 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 53cf92232ff69c6dea4b3ffc8d6d7f59a354afeb
Author: Gregory Collins <[email protected]>
Date: Fri Sep 17 23:08:04 2010 -0400
Get rid of annoying delay on exit
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 91a237e..fd40555 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -157,7 +157,6 @@ httpServe bindAddress bindPort localHostname alogPath
elogPath handler =
elog <- maybeSpawnLogger efp
return (alog, elog))
(\(alog, elog) -> do
- threadDelay 1000000
maybe (return ()) stopLogger alog
maybe (return ()) stopLogger elog)
@@ -699,7 +698,7 @@ sendResponse rsp' writeEnd onSendFile = do
return $ r' { rspBody = b }
where
- i :: forall a . Enumerator IO a -> Enumerator IO a
+ i :: forall z . Enumerator IO z -> Enumerator IO z
i enum iter = enum (joinI $ takeExactly cl iter)
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 5627768..7b69a77 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -47,11 +47,10 @@ import Data.Typeable
import Foreign hiding (new)
import Foreign.C.Error
import Foreign.C.Types
-import GHC.Conc (forkOnIO)
+import GHC.Conc (forkOnIO, numCapabilities)
import Network.Libev
import Network.Socket
import Prelude hiding (catch)
-import System.Timeout
------------------------------------------------------------------------------
-- FIXME: should be HashSet, make that later.
@@ -82,6 +81,7 @@ data Backend = Backend
, _killObj :: !EvAsyncPtr
, _connectionThreads :: !(HashMap ThreadId ())
, _backendCPU :: !Int
+ , _backendFreed :: !(MVar ())
}
@@ -216,6 +216,9 @@ new (sock,sockFd) cpu = do
-- thread set stuff
connSet <- H.new (H.hashString . show)
+ -- freed gets stuffed with () when all resources are released.
+ freed <- newEmptyMVar
+
let b = Backend sock
sockFd
connq
@@ -230,6 +233,7 @@ new (sock,sockFd) cpu = do
killObj
connSet
cpu
+ freed
forkOnIO cpu $ loopThread b
@@ -244,9 +248,11 @@ loopThread backend = do
(ignoreException go) `finally` cleanup
debug $ "loop finished"
where
- cleanup = do
+ cleanup = block $ do
debug $ "loopThread: cleaning up"
ignoreException $ freeBackend backend
+ putMVar (_backendFreed backend) ()
+
lock = _loopLock backend
loop = _evLoop backend
go = takeMVar lock >> block (evLoop loop 0)
@@ -288,43 +294,28 @@ ioWriteCallback fd active wa _loopPtr _ioPtr _ = do
writeIORef active False
-seconds :: Int -> Int
-seconds n = n * ((10::Int)^(6::Int))
-
-
stop :: Backend -> IO ()
stop b = ignoreException $ do
debug $ "Backend.stop"
- -- FIXME: what are we gonna do here?
- --
-- 1. take the loop lock
-- 2. shut down the accept() callback
-- 3. stuff a poison pill (a bunch of -1 values should do) down the
-- connection queue so that withConnection knows to throw an exception
-- back up to its caller
- -- 4. release the loop lock
- -- 5. wait until all of the threads have finished, or until 10 seconds have
- -- elapsed, whichever comes first
- -- 6. take the loop lock
- -- 7. call evUnloop and wake up the loop using evAsyncSend
- -- 8. release the loop lock, the main loop thread should then free/clean
+ -- 4. call evUnloop and wake up the loop using evAsyncSend
+ -- 5. release the loop lock, the main loop thread should then free/clean
-- everything up (threads, connections, io objects, callbacks, etc)
+ -- 6. wait for the loop thread to signal it has cleaned up and exited
withMVar lock $ \_ -> do
evIoStop loop acceptObj
- replicateM_ 10 $ writeChan connQ (-1)
-
- debug $ "Backend.stop: waiting at most 10 seconds for connection threads
to die"
- waitForThreads b $ seconds 10
- debug $ "Backend.stop: all threads presumed dead, unlooping"
-
- withMVar lock $ \_ -> do
+ replicateM_ (numCapabilities*2) $ writeChan connQ (-1)
evUnloop loop evunloop_all
evAsyncSend loop killObj
- debug $ "unloop sent"
-
+ debug $ "accepting threads killed, unloop sent, waiting for completion"
+ takeMVar $ _backendFreed b
where
loop = _evLoop b
@@ -335,18 +326,6 @@ stop b = ignoreException $ do
-waitForThreads :: Backend -> Int -> IO ()
-waitForThreads backend t = timeout t wait >> return ()
- where
- threadSet = _connectionThreads backend
- wait = do
- b <- H.null threadSet
- if b
- then return ()
- else threadDelay (seconds 1) >> wait
-
-
-
getAddr :: SockAddr -> IO (ByteString, Int)
getAddr addr =
case addr of
@@ -434,8 +413,6 @@ ignoreException = handle (\(_::SomeException) -> return ())
freeBackend :: Backend -> IO ()
freeBackend backend = ignoreException $ block $ do
-- note: we only get here after an unloop
-
-
-- kill everything in thread table
tset <- H.toList $ _connectionThreads backend
Prelude.mapM_ (killThread . fst) tset
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 5879e24..ace900c 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -138,34 +138,47 @@ new sock _ = do
let b = Backend sock ed t
- tid <- forkIO $ timeoutThread b PSQ.empty
+ tid <- forkIO $ timeoutThread b
putMVar t tid
return b
-timeoutThread :: Backend -> TimeoutTable -> IO ()
-timeoutThread backend = loop
- where
- loop tt = do
- tt' <- killTooOld tt
+timeoutThread :: Backend -> IO ()
+timeoutThread backend = do
+ tref <- newIORef $ PSQ.empty
+ let loop = do
+ killTooOld tref
threadDelay (5000000)
- loop tt'
+ loop
+ loop `catch` (\(_::SomeException) -> killAll tref)
- killTooOld table = do
+ where
+ killTooOld tref = do
+ !table <- readIORef tref
-- atomic swap edit list
now <- getCurrentDateTime
edits <- atomicModifyIORef tedits $ \t -> (D.empty, D.toList t)
let table' = foldl' (flip ($)) table edits
!t' <- killOlderThan now table'
- return t'
+ writeIORef tref t'
-- timeout = 30 seconds
tIMEOUT = 30
+ killAll !tref = do
+ debug "Backend.timeoutThread: shutdown, killing all connections"
+ !table <- readIORef tref
+ go table
+ where
+ go t = maybe (return ())
+ (\m -> (killThread $ PSQ.key m) >>
+ (go $ PSQ.deleteMin t))
+ (PSQ.findMin t)
+
killOlderThan now !table = do
debug "Backend.timeoutThread: killing old connections"
let mmin = PSQ.findMin table
@@ -190,7 +203,8 @@ stop (Backend s _ t) = do
debug $ "Backend.stop"
sClose s
- -- kill timeout thread and current thread
+ -- kill timeout thread and current thread; timeout thread handler will stop
+ -- all of the running connection threads
readMVar t >>= killThread
myThreadId >>= killThread
@@ -318,8 +332,8 @@ tickleTimeout conn = do
tedits = _timeoutEdits $ _backend conn
-cancelTimeout :: Connection -> IO ()
-cancelTimeout conn = do
+_cancelTimeout :: Connection -> IO ()
+_cancelTimeout conn = do
debug "Backend.cancelTimeout"
tid <- readMVar $ _connTid conn
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
