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, 0.5 has been updated
via 215b731c190b34d86c66fe8f200bdcde49365009 (commit)
via 2f54d2e1c41bef505128eb04fada034670e5166c (commit)
via fcc6f5a8970c7e8294269ce37b07b1591550f683 (commit)
from b571a53b581101c25275dc1e261470dd01eab4ba (commit)
Summary of changes:
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 215b731c190b34d86c66fe8f200bdcde49365009
Merge: b571a53 2f54d2e
Author: Gregory Collins <[email protected]>
Date: Fri Feb 11 05:42:34 2011 -0500
Merge branch 'master' into 0.5
commit 2f54d2e1c41bef505128eb04fada034670e5166c
Author: Gregory Collins <[email protected]>
Date: Fri Feb 11 05:40:46 2011 -0500
Revert "Refactor the Devel loader and export a second helper function". This
should be on 0.5 only.
This reverts commit b96c4bb62b533bcab9872403700a0d05bf183af4.
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 5a87d0d..1afd29b 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -7,7 +7,6 @@
-- the calls to the dynamic loader.
module Snap.Extension.Loader.Devel
( loadSnapTH
- , loadSnapTH'
) where
import Control.Monad (liftM2)
@@ -25,6 +24,7 @@ import System.Environment (getArgs)
------------------------------------------------------------------------------
import Snap.Types
+import Snap.Extension (runInitializerWithoutReloadAction)
import Snap.Extension.Loader.Devel.Signal
import Snap.Extension.Loader.Devel.Evaluator
import Snap.Extension.Loader.Devel.TreeWatcher
@@ -44,43 +44,23 @@ import Snap.Extension.Loader.Devel.TreeWatcher
-- during development unless your .cabal file changes, or the code
-- that uses this splice changes.
loadSnapTH :: Name -> Name -> [String] -> Q Exp
-loadSnapTH initializer action additionalWatchDirs =
- loadSnapTH' modules imports additionalWatchDirs loadStr
- where
- initMod = nameModule initializer
- initBase = nameBase initializer
- actMod = nameModule action
- actBase = nameBase action
-
- modules = catMaybes [initMod, actMod]
- imports = ["Snap.Extension"]
-
- loadStr = intercalate " " [ "runInitializerWithoutReloadAction"
- , initBase
- , actBase
- ]
-
-
-------------------------------------------------------------------------------
--- | This is the backing implementation for 'loadSnapTH'. This
--- interface can be used when the types involved don't include a
--- SnapExtend and an Initializer.
-loadSnapTH' :: [String] -- ^ the list of modules to interpret
- -> [String] -- ^ the list of modules to import in addition
- -- to those being interpreted
- -> [String] -- ^ additional directories to watch for
- -- changes to trigger to recompile/reload
- -> String -- ^ the expression to interpret in the
- -- context of the loaded modules and imports.
- -- It should have the type 'HintLoadable'
- -> Q Exp
-loadSnapTH' modules imports additionalWatchDirs loadStr = do
+loadSnapTH initializer action additionalWatchDirs = do
args <- runIO getArgs
- let opts = getHintOpts args
+ let initMod = nameModule initializer
+ initBase = nameBase initializer
+ actMod = nameModule action
+ actBase = nameBase action
+
+ opts = getHintOpts args
+ modules = catMaybes [initMod, actMod]
srcPaths = additionalWatchDirs ++ getSrcPaths args
- [| hintSnap opts modules imports srcPaths loadStr |]
+ -- The let in this block causes an extra static type check that the
+ -- types of the names passed in were correct at compile time.
+ [| let _ = runInitializerWithoutReloadAction $(varE initializer)
+ $(varE action)
+ in hintSnap opts modules srcPaths initBase actBase |]
------------------------------------------------------------------------------
@@ -133,21 +113,24 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-- modules which contain the initialization,
-- cleanup, and handler actions. Everything else
-- they require will be loaded transitively.
- -> [String] -- ^ A list of modules that need to be be
- -- imported, in addition to the ones that need to
- -- be interpreted. This only needs to contain
- -- modules that aren't being interpreted, such as
- -- those from other libraries, that are used in
- -- the expression passed in.
-> [String] -- ^ A list of paths to watch for updates
- -> String -- ^ The string to execute
+ -> String -- ^ The name of the initializer action
+ -> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
-hintSnap opts modules imports srcPaths action =
+hintSnap opts modules srcPaths initialization handler =
protectedHintEvaluator initialize test loader
where
+ action = intercalate " " [ "runInitializerWithoutReloadAction"
+ , initialization
+ , handler
+ ]
interpreter = do
loadModules . nub $ modules
- setImports . nub $ "Prelude" : "Snap.Types" : imports ++ modules
+ let imports = "Prelude" :
+ "Snap.Extension" :
+ "Snap.Types" :
+ modules
+ setImports . nub $ imports
interpret action (as :: HintLoadable)
commit fcc6f5a8970c7e8294269ce37b07b1591550f683
Author: Gregory Collins <[email protected]>
Date: Fri Feb 11 05:39:52 2011 -0500
Revert "Fix handling of cleanup actions on server shutdown in development
mode". This commit should be on the 0.5 branch only for now.
This reverts commit ba3d8ac60131a4277e4549a3fe21eac118a6751c.
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
index 56c52d9..332ccc8 100644
--- a/project_template/default/src/Main.hs
+++ b/project_template/default/src/Main.hs
@@ -42,8 +42,6 @@ change.
module Main where
#ifdef DEVELOPMENT
-import Control.Exception (SomeException, try)
-
import Snap.Extension.Loader.Devel
import Snap.Http.Server (quickHttpServe)
#else
@@ -59,10 +57,9 @@ main = do
-- All source directories will be watched for updates
-- automatically. If any extra directories should be watched for
-- updates, include them here.
- (snap, cleanup) <- $(let watchDirs = ["resources/templates"]
- in loadSnapTH 'applicationInitializer 'site watchDirs)
- try $ quickHttpServe snap :: IO (Either SomeException ())
- cleanup
+ snap <- $(let extraWatcheDirs = ["resources/templates"]
+ in loadSnapTH 'applicationInitializer 'site extraWatcheDirs)
+ quickHttpServe snap
#else
main = quickHttpServe applicationInitializer site
#endif
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 47ab857..5a87d0d 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 ())
+ -> IO (Snap ())
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 3820763..01b1c16 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 ())
+ -> IO (Snap ())
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,78 +61,70 @@ 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.
- 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)
+ 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
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
