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, reload-less has been updated
via 25d1c25d8019cb9ed08c074d10b9b46291b42156 (commit)
via 9d5c7967cf67fd3b617b99964bb1658fc32c41f5 (commit)
from 91c7ddb490faae6d7aa53c0793bcacd6e0fcdd27 (commit)
Summary of changes:
snap.cabal | 4 +-
src/Snap/Extension.hs | 77 +++++------
src/Snap/Extension/Loader/Devel.hs | 134 +++---------------
src/Snap/Extension/Loader/Devel/Evaluator.hs | 149 ++++++++++++++++++++
.../Loader/Devel/{Helper.hs => Signal.hs} | 2 +-
5 files changed, 207 insertions(+), 159 deletions(-)
create mode 100644 src/Snap/Extension/Loader/Devel/Evaluator.hs
rename src/Snap/Extension/Loader/Devel/{Helper.hs => Signal.hs} (92%)
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 25d1c25d8019cb9ed08c074d10b9b46291b42156
Author: Carl Howells <[email protected]>
Date: Tue Dec 21 15:23:01 2010 -0800
Reload app in-memory state only on recompile
diff --git a/snap.cabal b/snap.cabal
index c771af2..e448e0b 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -37,12 +37,13 @@ Library
Snap.Extension.Heist,
Snap.Extension.Heist.Impl,
Snap.Extension.Loader.Devel,
+ Snap.Extension.Loader.Devel.Evaluator,
Snap.Extension.Server,
Snap.Extension,
Snap.Heist
other-modules:
- Snap.Extension.Loader.Devel.Helper
+ Snap.Extension.Loader.Devel.Signal
build-depends:
base >= 4 && < 5,
@@ -50,6 +51,7 @@ Library
directory >= 1.0 && < 1.2,
enumerator == 0.4.*,
filepath >= 1.1 && <1.3,
+ ghc-prim,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
snap-core == 0.3.*,
heist >= 0.4 && < 0.5,
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index 4c16408..262a5ad 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-
module Snap.Extension
( -- * Introduction
-- $introduction
@@ -26,7 +25,7 @@ module Snap.Extension
, InitializerState(..)
, runInitializer
, runInitializerWithReloadAction
- , runInitializerHint
+ , getHintInternals
, mkInitializer
, defaultReloadHandler
, nullReloadHandler
@@ -43,7 +42,8 @@ import qualified Data.ByteString.Char8 as B
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import Prelude hiding (catch)
+import Prelude hiding (catch, init)
+import Snap.Extension.Loader.Devel.Evaluator
import Snap.Iteratee (enumBS, (>==>))
import Snap.Types
import System.IO
@@ -408,21 +408,16 @@ runInitializerWithReloadAction v (Initializer r) se f = do
Right (SCR s a b) -> return (s, a, b)
------------------------------------------------------------------------------
--- | Runs an initializer, obtains state, runs the handler, and tears everything
--- down all in one request. Used with the hint backend which reloads everything
--- every time.
-runInitializerHint :: Initializer s
- -- ^ The Initializer value
- -> SnapExtend s ()
- -- ^ An action in your application's monad.
- -> Snap ()
-runInitializerHint (Initializer r) (SnapExtend m) = do
- liftIO (r True) >>= either
- -- Left s: no cleanup action
- (\s -> runReaderT m s)
- f
- where
- f (SCR s a _) = runReaderT m s `finally` liftIO a
+-- | Translates an Initializer and SnapExtend into a HintInternals
+-- object, used by the hint loading code.
+getHintInternals :: Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad.
+ -> IO HintInternals
+getHintInternals i se = do
+ (action, cleanup, _) <- runInitializer True i se
+ return $ makeHintInternals (return ()) (const cleanup) (const action)
------------------------------------------------------------------------------
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 9439ea8..5332968 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -9,30 +9,25 @@ module Snap.Extension.Loader.Devel
( loadSnapTH
) where
-import Data.List (groupBy, intercalate, isPrefixOf, nub)
+import Control.Monad (join)
-import Control.Concurrent (forkIO, myThreadId)
-import Control.Concurrent.MVar
-import Control.Exception
-import Control.Monad (when)
-import Control.Monad.Trans (liftIO)
+import Data.List (groupBy, intercalate, isPrefixOf, nub)
import Data.Maybe (catMaybes)
-import Data.Time.Clock
import Language.Haskell.Interpreter hiding (lift, liftIO)
import Language.Haskell.Interpreter.Unsafe
import Language.Haskell.TH
-import Prelude hiding (catch)
import System.Environment (getArgs)
------------------------------------------------------------------------------
import Snap.Types
-import Snap.Extension (runInitializerHint)
-import Snap.Extension.Loader.Devel.Helper
+import Snap.Extension (getHintInternals)
+import Snap.Extension.Loader.Devel.Signal
+import Snap.Extension.Loader.Devel.Evaluator
------------------------------------------------------------------------------
-- | This function derives all the information necessary to use the
@@ -65,22 +60,12 @@ loadSnapTH initializer action = do
modules = catMaybes [initMod, actMod]
opts = getHintOpts args
- let static = typecheck initializer action
-
- -- The let in this block causes the static expression to be
- -- pattern-matched, providing an extra check that the types were
- -- correct at compile-time, at least.
- [| let _ = $static :: IO (Snap ())
+ -- 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 _ = getHintInternals $(varE initializer) $(varE action)
in hintSnap opts modules initBase actBase |]
--- Used to typecheck the initializer & action splices.
-typecheck :: Name -> Name -> Q Exp
-typecheck initializer action = do
- let [initE, actE] = map varE [initializer, action]
- [| return (runInitializerHint $initE $actE) |]
-
-
------------------------------------------------------------------------------
-- | Convert the command-line arguments passed in to options for the
-- hint interpreter. This is somewhat brittle code, based on a few
@@ -133,28 +118,27 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
hintSnap opts modules initialization handler = do
- let action = intercalate " " [ "runInitializerHint"
+ let action = intercalate " " [ "getHintInternals"
, initialization
, handler
]
interpreter = do
loadModules . nub $ modules
- let imports = ["Prelude", "Snap.Types", "Snap.Extension"] ++
modules
+ let imports = "Prelude" : "Snap.Extension" :
+ "Snap.Extension.Loader.Devel.Evaluator" :
+ modules
setImports . nub $ imports
- interpret action (as :: Snap ())
+ interpret action (as :: IO HintInternals)
loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
- -- Protect the interpreter from concurrent and high-speed serial
- -- access.
- loadAction <- protectedActionEvaluator 3 $ protectHandlers loadInterpreter
+ formatError (Left err) = error $ format err
+ formatError (Right a) = a
- return $ do
- interpreterResult <- liftIO loadAction
- case interpreterResult of
- Left err -> error $ format err
- Right handlerAction -> handlerAction
+ loader = join $ formatError `fmap` protectHandlers loadInterpreter
+
+ protectedHintEvaluator 3 loader
------------------------------------------------------------------------------
@@ -166,85 +150,3 @@ format (GhcException e) = "GHC error:\r\n\r\n" ++ e
format (WontCompile errs) = "Compile errors:\r\n\r\n" ++
(intercalate "\r\n" $ nub $ map errMsg errs)
-
-------------------------------------------------------------------------------
--- | Create a wrapper for an action that protects the action from
--- concurrent or rapid evaluation.
---
--- There will be at least the passed-in 'NominalDiffTime' delay
--- between the finish of one execution of the action the start of the
--- next. Concurrent calls to the wrapper, and calls within the delay
--- period, end up with the same calculated value returned.
---
--- If an exception is raised during the processing of the action, it
--- will be thrown to all waiting threads, and 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
- -- The list of requesters waiting for a result. Contains the
- -- ThreadId in case of exceptions, and an empty MVar awaiting a
- -- successful result.
- --
- -- type: MVar [(ThreadId, MVar a)]
- readerContainer <- newMVar []
-
- -- Contains the previous result, and the time it was stored, if a
- -- previous result has been computed. The result stored is either
- -- the actual result, or the exception thrown by the calculation.
- --
- -- type: MVar (Maybe (Either SomeException a, UTCTime))
- resultContainer <- newMVar Nothing
-
- -- The model used for the above MVars in the returned action is
- -- "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
- existingResult <- readMVar resultContainer
- now <- getCurrentTime
-
- case existingResult of
- Just (res, ts) | diffUTCTime now ts < minReEval ->
- -- There's an existing result, and it's still valid
- case res of
- Right val -> return val
- Left e -> throwIO e
- _ -> 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, kick off evaluation of
- -- the action in a new thread. This is slightly
- -- careful to block asynchronous exceptions to that
- -- thread except when actually running the action.
- when (null readers) $ do
- 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 ()
-
- -- Wait for the evaluation of the action to complete,
- -- and return its result.
- takeMVar reader
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
new file mode 100644
index 0000000..a10b179
--- /dev/null
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Snap.Extension.Loader.Devel.Evaluator
+ ( HintInternals
+ , makeHintInternals
+ , protectedHintEvaluator
+ ) where
+
+
+import Control.Exception
+import Control.Monad (when)
+import Control.Monad.Trans (liftIO)
+
+import Control.Concurrent (forkIO, myThreadId)
+import Control.Concurrent.MVar
+
+import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
+import Data.Typeable (Typeable)
+
+import GHC.Prim (Any)
+
+import Prelude hiding (catch, init, any)
+
+import Snap.Types (Snap)
+
+import Unsafe.Coerce (unsafeCoerce)
+
+
+------------------------------------------------------------------------------
+-- | A monomorphic type to hide polymorphism. This allows Hint to
+-- load the action, since it requires loading a monomorphic type. The
+-- constructor for this is not exposed because its internals are
+-- incredibly far from type safe.
+data HintInternals = HintInternals
+ { hiInit :: IO Any
+ , hiClean :: Any -> IO ()
+ , hiExec :: Any -> Snap ()
+ } deriving Typeable
+
+
+------------------------------------------------------------------------------
+-- | A smart constructor to hide the incredibly type unsafe internals
+-- of HintInternals behind a type safe smart constructor.
+makeHintInternals :: IO a -> (a -> IO ()) -> (a -> Snap ()) -> HintInternals
+makeHintInternals init clean exec = HintInternals init' clean' exec'
+ where
+ init' = fmap unsafeCoerce init
+ clean' = clean . unsafeCoerce
+ exec' = exec . unsafeCoerce
+
+
+------------------------------------------------------------------------------
+-- | Convert an action to generate HintInternals into an action to
+-- generate Snap actions. The resulting action will share initialized
+-- state until the next execution of the input action. At this time,
+-- the cleanup action will be executed.
+--
+-- There will be at least the passed-in 'NominalDiffTime' delay
+-- between the finish of one execution of the action the start of the
+-- next. Concurrent calls to the wrapper, and calls within the delay
+-- period, end up with the same calculated value returned.
+--
+-- If an exception is raised during the processing of the action, it
+-- will be thrown to all waiting threads, and for all requests made
+-- before the delay time has expired after the exception was raised.
+protectedHintEvaluator :: NominalDiffTime
+ -> IO HintInternals
+ -> IO (Snap ())
+protectedHintEvaluator minReEval action = do
+ -- The list of requesters waiting for a result. Contains the
+ -- ThreadId in case of exceptions, and an empty MVar awaiting a
+ -- successful result.
+ --
+ -- type: MVar [(ThreadId, MVar (Snap ()))]
+ readerContainer <- newMVar []
+
+ -- Contains the previous result and initialization value, and the
+ -- time it was stored, if a previous result has been computed.
+ -- The result stored is either the actual result and
+ -- initialization result, or the exception thrown by the
+ -- calculation.
+ --
+ -- type: MVar (Maybe (Either SomeException (HintInternals, Any), UTCTime))
+ resultContainer <- newMVar Nothing
+
+ -- The model used for the above MVars in the returned action is
+ -- "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
+ existingResult <- liftIO $ readMVar resultContainer
+ now <- liftIO getCurrentTime
+
+ (hi, any) <- liftIO $ case existingResult of
+ Just (res, ts) | diffUTCTime now ts < minReEval ->
+ -- There's an existing result, and it's still valid
+ case res of
+ Right x -> return x
+ Left e -> throwIO e
+ _ -> 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 action and initialize its state
+ hi <- unblock action
+ any <- unblock $ hiInit hi
+
+ let a = (hi, any)
+ 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 ()
+
+ -- Wait for the evaluation of the action to complete,
+ -- and return its result.
+ takeMVar reader
+ hiExec hi any
+ where
+ cleanup (Just (Right (hi, any), _)) = hiClean hi any
+ cleanup _ = return ()
diff --git a/src/Snap/Extension/Loader/Devel/Helper.hs
b/src/Snap/Extension/Loader/Devel/Signal.hs
similarity index 92%
rename from src/Snap/Extension/Loader/Devel/Helper.hs
rename to src/Snap/Extension/Loader/Devel/Signal.hs
index 24c8030..5bc355b 100644
--- a/src/Snap/Extension/Loader/Devel/Helper.hs
+++ b/src/Snap/Extension/Loader/Devel/Signal.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
-module Snap.Extension.Loader.Devel.Helper (protectHandlers) where
+module Snap.Extension.Loader.Devel.Signal (protectHandlers) where
import Control.Exception (bracket)
commit 9d5c7967cf67fd3b617b99964bb1658fc32c41f5
Author: Carl Howells <[email protected]>
Date: Mon Dec 20 21:43:38 2010 -0800
whitespace
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index 54fd841..4c16408 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -5,19 +5,19 @@
module Snap.Extension
( -- * Introduction
-- $introduction
-
+
-- ** Using Snap Extensions
-- $using
-
+
-- *** Define Application State and Monad
-- $definingtypes
-
+
-- *** Provide Instances For \"HasState\" Classes
-- $hasstateclasses
-- *** Define The Initializer
-- $initializer
-
+
-- *** Simplified Snap Extension Server
-- $httpserve
@@ -67,14 +67,14 @@ import System.IO
-}
{- $using
-
+
Every extension has an interface and at least one implementation of that
- interface.
-
+ interface.
+
For some extensions, like Heist, there is only ever going to be one
implementation of the interface. In these cases, both the interface and the
implementation are exported from the same module, Snap.Extension.Heist.Impl.
-
+
Hypothetically, for something like session management though, there could be
multiple implementations, one using a HDBC backend, one using a MongoDB
backend and one just using an encrypted cookie as backend. In these cases,
@@ -89,7 +89,7 @@ import System.IO
-}
{- $definingtypes
-
+
First, we define a record type AppState for holding our application's state,
including the state needed by the extensions we're using.
@@ -120,7 +120,7 @@ data AppState = AppState
This state is what the extension's implementation needs to be able to do its
job.
-
+
-}
{- $hasstateclasses
@@ -137,7 +137,7 @@ data AppState = AppState
@render :: MonadHeist m => ByteString -> m ()@ that renders a template by its
name.
-
+
Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also
a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'.
That sounds a lot like our App, doesn't it? We just have to tell the Heist
@@ -153,11 +153,11 @@ instance HasHeistState AppState where
and let the HasHeistState typeclass know how to get/set this state, we are
/automagically/ given the ability to render heist templates in our handlers.
- With these instances, our application's monad App is now a MonadHeist
+ With these instances, our application's monad App is now a MonadHeist
giving it access to operations like:
-
- @render :: MonadHeist m => ByteString -> m ()@
-
+
+ @render :: MonadHeist m => ByteString -> m ()@
+
and
@heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@
@@ -165,11 +165,11 @@ instance HasHeistState AppState where
-}
{- $initializer
-
+
So, our monad is now a 'MonadHeist', but how do we actually construct our
AppState and turn an App () into a 'Snap' ()? We need to do this upfront,
once and right before our web server starts listening for connections.
-
+
Snap extensions have a thing called an 'Initializer' that does these things.
Each implementation of a Snap extension interface provides an 'Initializer'
for its -State type. We must construct an initializer type for our -State
@@ -186,8 +186,8 @@ appInitializer = do
In addition to constructing the AppState, the Initializer monad also
constructs the init, destroy and reload functions for our application from
- the init, reload and destroy functions for the extensions.
-
+ the init, reload and destroy functions for the extensions.
+
Although it won't cause a compile-time error, it is important to get the
order of the initializers correct as much as possible, otherwise they may be
reloaded and destroyed in the wrong order. The "right" order is an order
@@ -210,7 +210,7 @@ appInitializer = do
main :: IO ()
main = do
(snap,cleanup,reload) <- runInitializer appInitializer appSite
- let site = snap
+ let site = snap
<|> path "admin/reload" $ defaultReloadHandler reload cleanup
quickHttpServe site `finally` cleanup
@
@@ -226,7 +226,7 @@ main = do
-}
{- $httpserve
-
+
This is, of course, a lot of avoidable boilerplate. Snap extensions framework
comes with another module "Snap.Extension.Server", which provides an interface
mimicking that of "Snap.Http.Server". Their function names clash, so if you
@@ -246,8 +246,8 @@ main = quickHttpServe appRunner site
One quick note: 'quickHttpServe' doesn't take a config, instead it uses the
defaults augmented with any options specified on the command-line. The
- default reload handler path in this case is "admin/reload".
-
+ default reload handler path in this case is "admin/reload".
+
If you wanted to change this to nullReloadHandler, this is what you would do:
@
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
