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 ba3d8ac60131a4277e4549a3fe21eac118a6751c (commit)
from b96c4bb62b533bcab9872403700a0d05bf183af4 (commit)
Summary of changes:
project_template/default/src/Main.hs | 9 +-
src/Snap/Extension/Loader/Devel.hs | 2 +-
src/Snap/Extension/Loader/Devel/Evaluator.hs | 138 ++++++++++++++------------
3 files changed, 80 insertions(+), 69 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 ba3d8ac60131a4277e4549a3fe21eac118a6751c
Author: Carl Howells <[email protected]>
Date: Tue Feb 8 11:29:20 2011 -0800
Fix handling of cleanup actions on server shutdown in development mode
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
index 332ccc8..56c52d9 100644
--- a/project_template/default/src/Main.hs
+++ b/project_template/default/src/Main.hs
@@ -42,6 +42,8 @@ change.
module Main where
#ifdef DEVELOPMENT
+import Control.Exception (SomeException, try)
+
import Snap.Extension.Loader.Devel
import Snap.Http.Server (quickHttpServe)
#else
@@ -57,9 +59,10 @@ main = do
-- All source directories will be watched for updates
-- automatically. If any extra directories should be watched for
-- updates, include them here.
- snap <- $(let extraWatcheDirs = ["resources/templates"]
- in loadSnapTH 'applicationInitializer 'site extraWatcheDirs)
- quickHttpServe snap
+ (snap, cleanup) <- $(let watchDirs = ["resources/templates"]
+ in loadSnapTH 'applicationInitializer 'site watchDirs)
+ try $ quickHttpServe snap :: IO (Either SomeException ())
+ cleanup
#else
main = quickHttpServe applicationInitializer site
#endif
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 5a87d0d..47ab857 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -141,7 +141,7 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-- the expression passed in.
-> [String] -- ^ A list of paths to watch for updates
-> String -- ^ The string to execute
- -> IO (Snap ())
+ -> IO (Snap (), IO ())
hintSnap opts modules imports srcPaths action =
protectedHintEvaluator initialize test loader
where
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
index 01b1c16..3820763 100644
--- a/src/Snap/Extension/Loader/Devel/Evaluator.hs
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -43,7 +43,7 @@ protectedHintEvaluator :: forall a.
IO a
-> (a -> IO Bool)
-> IO HintLoadable
- -> IO (Snap ())
+ -> IO (Snap (), IO ())
protectedHintEvaluator start test getInternals = do
-- The list of requesters waiting for a result. Contains the
-- ThreadId in case of exceptions, and an empty MVar awaiting a
@@ -61,70 +61,78 @@ protectedHintEvaluator start test getInternals = do
-- "keep them full, unless updating them." In every case, when
-- one of those MVars is emptied, the next action is to fill that
-- same MVar. This makes deadlocking on MVar wait impossible.
- return $ do
- let waitForNewResult :: IO (Snap ())
- waitForNewResult = do
- -- Need to calculate a new result
- tid <- myThreadId
- reader <- newEmptyMVar
-
- readers <- takeMVar readerContainer
-
- -- Some strictness is employed to ensure the MVar
- -- isn't holding on to a chain of unevaluated thunks.
- let pair = (tid, reader)
- newReaders = readers `seq` pair `seq` (pair : readers)
- putMVar readerContainer $! newReaders
-
- -- If this is the first reader to queue, clean up the
- -- previous state, if there was any, and then begin
- -- evaluation of the new code and state.
- when (null readers) $ do
- let runAndFill = block $ do
- -- run the cleanup action
- previous <- readMVar resultContainer
- unblock $ cleanup previous
-
- -- compile the new internals and initialize
- stateInitializer <- unblock getInternals
- res <- unblock stateInitializer
-
- let a = fst res
-
- clearAndNotify (Right res) (flip putMVar a . snd)
-
- killWaiting :: SomeException -> IO ()
- killWaiting e = block $ do
- clearAndNotify (Left e) (flip throwTo e . fst)
- throwIO e
-
- clearAndNotify r f = do
- a <- unblock start
- _ <- swapMVar resultContainer $ Just (r, a)
- allReaders <- swapMVar readerContainer []
- mapM_ f allReaders
-
- _ <- forkIO $ runAndFill `catch` killWaiting
- return ()
-
- -- Wait for the evaluation of the action to complete,
- -- and return its result.
- takeMVar reader
-
- existingResult <- liftIO $ readMVar resultContainer
-
- getResult <- liftIO $ case existingResult of
- Just (res, a) -> do
- -- There's an existing result. Check for validity
- valid <- test a
- case (valid, res) of
- (True, Right (x, _)) -> return x
- (True, Left e) -> throwIO e
- (False, _) -> do
- _ <- swapMVar resultContainer Nothing
- waitForNewResult
- Nothing -> waitForNewResult
- getResult
+ let snap = do
+ let waitForNewResult :: IO (Snap ())
+ waitForNewResult = do
+ -- Need to calculate a new result
+ tid <- myThreadId
+ reader <- newEmptyMVar
+
+ readers <- takeMVar readerContainer
+
+ -- Some strictness is employed to ensure the MVar
+ -- isn't holding on to a chain of unevaluated thunks.
+ let pair = (tid, reader)
+ newReaders = readers `seq` pair `seq` (pair : readers)
+ putMVar readerContainer $! newReaders
+
+ -- If this is the first reader to queue, clean up the
+ -- previous state, if there was any, and then begin
+ -- evaluation of the new code and state.
+ when (null readers) $ do
+ let runAndFill = block $ do
+ -- run the cleanup action
+ previous <- readMVar resultContainer
+ unblock $ cleanup previous
+
+ -- compile the new internals and initialize
+ stateInitializer <- unblock getInternals
+ res <- unblock stateInitializer
+
+ let a = fst res
+
+ clearAndNotify (Right res) (flip putMVar a .
snd)
+
+ killWaiting :: SomeException -> IO ()
+ killWaiting e = block $ do
+ clearAndNotify (Left e) (flip throwTo e . fst)
+ throwIO e
+
+ clearAndNotify r f = do
+ a <- unblock start
+ _ <- swapMVar resultContainer $ Just (r, a)
+ allReaders <- swapMVar readerContainer []
+ mapM_ f allReaders
+
+ _ <- forkIO $ runAndFill `catch` killWaiting
+ return ()
+
+ -- Wait for the evaluation of the action to complete,
+ -- and return its result.
+ takeMVar reader
+
+ existingResult <- liftIO $ readMVar resultContainer
+
+ getResult <- liftIO $ case existingResult of
+ Just (res, a) -> do
+ -- There's an existing result. Check for validity
+ valid <- test a
+ case (valid, res) of
+ (True, Right (x, _)) -> return x
+ (True, Left e) -> throwIO e
+ (False, _) -> do
+ _ <- swapMVar resultContainer Nothing
+ waitForNewResult
+ Nothing -> waitForNewResult
+ getResult
+
+ clean = do
+ let msg = "invalid dynamic loader state. " ++
+ "The cleanup action has been executed"
+ contents <- swapMVar resultContainer $ error msg
+ cleanup contents
+
+ return (snap, clean)
where
newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])
newReaderContainer = newMVar []
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
