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".
The branch, master has been updated
via 0d636df731570db814f2a7a1be3fc09569e09517 (commit)
from e007b4b327a4b34e8364d5802ab041fe363bd7e0 (commit)
Summary of changes:
TODO | 4 ----
src/Snap/Loader/Hint.hs | 42 +++++++++++++++++++++++++++++++-----------
2 files changed, 31 insertions(+), 15 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 0d636df731570db814f2a7a1be3fc09569e09517
Author: Carl Howells <[email protected]>
Date: Wed Jun 30 11:53:50 2010 -0700
Make the protectedActionEvaluator exception-safe
diff --git a/TODO b/TODO
index 25e13be..5010138 100644
--- a/TODO
+++ b/TODO
@@ -1,10 +1,6 @@
TODO
----
-Make the protectedActionEvaluator exception-safe.
- -- The best approach is to just throw whatever exception
- it catches to all the waiting threads.
-
document EVERYTHING.
-- low-level per-function documentation
-- mid-level per-module documentation
diff --git a/src/Snap/Loader/Hint.hs b/src/Snap/Loader/Hint.hs
index cc607d5..4cb7fa1 100644
--- a/src/Snap/Loader/Hint.hs
+++ b/src/Snap/Loader/Hint.hs
@@ -8,8 +8,9 @@ import qualified Data.ByteString.Char8 as S
import Data.List (groupBy, intercalate, isPrefixOf, nub)
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, myThreadId)
import Control.Concurrent.MVar
+import Control.Exception
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
@@ -21,6 +22,8 @@ import Language.Haskell.Interpreter.Unsafe
(unsafeSetGhcOption)
import Language.Haskell.TH.Syntax
+import Prelude hiding (catch)
+
import System.Environment (getArgs)
------------------------------------------------------------------------------
@@ -133,7 +136,9 @@ format (WontCompile errs) =
-- next. Concurrent calls to the wrapper, and calls within the delay
-- period, end up with the same calculated value for a.
--
--- TODO: make this exception-safe
+-- If an exception is raised during the processing of the action, it
+-- will be thrown to all waiting threads, for all requests made before
+-- the delay time has expired after the exception was raised.
protectedActionEvaluator :: NominalDiffTime -> IO a -> IO (IO a)
protectedActionEvaluator minReEval action = do
readerContainer <- newMVar []
@@ -143,20 +148,35 @@ protectedActionEvaluator minReEval action = do
now <- getCurrentTime
case existingResult of
- Just (val, ts) | diffUTCTime now ts < minReEval -> return val
+ Just (res, ts) | diffUTCTime now ts < minReEval ->
+ case res of
+ Right val -> return val
+ Left e -> throwIO e
_ -> do
reader <- newEmptyMVar
readers <- takeMVar readerContainer
when (null readers) $ do
- forkIO $ do
- result <- action
- allReaders <- takeMVar readerContainer
- finishTime <- getCurrentTime
- swapMVar resultContainer $ Just (result, finishTime)
- putMVar readerContainer []
- mapM_ (flip putMVar result) allReaders
+ let runAndFill = block $ do
+ a <- unblock action
+ clearAndNotify (Right a) (flip putMVar a . snd)
+
+ killWaiting :: SomeException -> IO ()
+ killWaiting e = block $ do
+ clearAndNotify (Left e) (flip throwTo e . fst)
+ throwIO e
+
+ clearAndNotify r f = do
+ t <- getCurrentTime
+ _ <- swapMVar resultContainer $ Just (r, t)
+ allReaders <- swapMVar readerContainer []
+ mapM_ f allReaders
+
+ forkIO $ runAndFill `catch` killWaiting
return ()
- putMVar readerContainer $ reader : readers
+ tid <- myThreadId
+ let pair = (tid, reader)
+ newReaders = pair `seq` (pair : readers)
+ putMVar readerContainer $! newReaders
takeMVar reader
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
