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 25b4ea0d61e60b2fb5ba80c388f88441de5f0bac (commit)
from 71266cfb01d06ee21eeb896763166de1ef3f27b9 (commit)
Summary of changes:
project_template/default/foo.cabal | 5 +-
project_template/default/src/Main.hs | 86 +++++++++++-----------
project_template/default/src/Site.hs | 2 +-
snap.cabal | 3 +-
src/Snap/Extension/Loader/Devel.hs | 92 +++++++++++++-----------
src/Snap/Extension/Loader/Devel/Evaluator.hs | 2 +-
src/Snap/Extension/Loader/Devel/TreeWatcher.hs | 46 ++++++++++++
7 files changed, 145 insertions(+), 91 deletions(-)
create mode 100644 src/Snap/Extension/Loader/Devel/TreeWatcher.hs
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 25b4ea0d61e60b2fb5ba80c388f88441de5f0bac
Author: Carl Howells <[email protected]>
Date: Sat Dec 25 16:27:11 2010 -0800
Explicitly watch for changes before recompiling
diff --git a/project_template/default/foo.cabal
b/project_template/default/foo.cabal
index 778f768..e4ecb0b 100644
--- a/project_template/default/foo.cabal
+++ b/project_template/default/foo.cabal
@@ -18,9 +18,8 @@ Executable projname
hs-source-dirs: src
main-is: Main.hs
- if !flag(development)
- cpp-options: -DPRODUCTION
- else
+ if flag(development)
+ cpp-options: -DDEVELOPMENT
build-depends: hint >= 0.3.2 && < 0.4
Build-depends:
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
index c1fe8dc..332ccc8 100644
--- a/project_template/default/src/Main.hs
+++ b/project_template/default/src/Main.hs
@@ -3,61 +3,63 @@
{-|
-This is the entry point for this web server application. It supports easily
-switching between interpreting source and running statically compiled code.
-
-In either mode, the generated program should be run from the root of the
-project tree. It locates its templates, static content, and source files in
-development mode, relative to the current working directory when it is run.
-
-When compiled without the production flag, only changes to the libraries, your
-cabal file, or this file should require a recompile to be picked up.
-Everything else is interpreted at runtime. There are a few consequences of
-this.
-
-First, this is much slower. Running the interpreter seems to take about
-300ms, regardless of the simplicity of the loaded code. The results of the
-interpreter process are cached for a few seconds, to hopefully ensure that
-the the interpreter is only invoked once for each load of a page and the
-resources it depends on.
-
-Second, the generated server binary is MUCH larger, since it links in the GHC
-API (via the hint library).
-
-Third, it results in initialization\/cleanup code defined by the @Initializer@
-being called for each request. This is to ensure that the current state is
-compatible with the running action. If your application state takes a long
-time to load or clean up, the penalty will be visible.
-
-Fourth, and the reason you would ever want to actually compile without
-production mode, is that it enables a *much* faster development cycle. You can
-simply edit a file, save your changes, and hit reload to see your changes
-reflected immediately.
-
-When this is compiled with the production flag, all the actions are statically
-compiled in. This results in much faster execution, a smaller binary size,
-only running initialization and cleanup once per application run, and having
-to recompile the server for any code change.
+This is the entry point for this web server application. It supports
+easily switching between interpreting source and running statically
+compiled code.
+
+In either mode, the generated program should be run from the root of
+the project tree. When it is run, it locates its templates, static
+content, and source files in development mode, relative to the current
+working directory.
+
+When compiled with the development flag, only changes to the
+libraries, your cabal file, or this file should require a recompile to
+be picked up. Everything else is interpreted at runtime. There are a
+few consequences of this.
+
+First, this is much slower. Running the interpreter takes a
+significant chunk of time (a couple tenths of a second on the author's
+machine, at this time), regardless of the simplicity of the loaded
+code. In order to recompile and re-load server state as infrequently
+as possible, the source directories are watched for updates, as are
+any extra directories specified below.
+
+Second, the generated server binary is MUCH larger, since it links in
+the GHC API (via the hint library).
+
+Third, and the reason you would ever want to actually compile with
+development mode, is that it enables a faster development cycle. You
+can simply edit a file, save your changes, and hit reload to see your
+changes reflected immediately.
+
+When this is compiled without the development flag, all the actions
+are statically compiled in. This results in faster execution, a
+smaller binary size, and having to recompile the server for any code
+change.
-}
module Main where
-#ifdef PRODUCTION
-import Snap.Extension.Server
-#else
+#ifdef DEVELOPMENT
import Snap.Extension.Loader.Devel
import Snap.Http.Server (quickHttpServe)
+#else
+import Snap.Extension.Server
#endif
import Application
import Site
main :: IO ()
-#ifdef PRODUCTION
-main = quickHttpServe applicationInitializer site
-#else
+#ifdef DEVELOPMENT
main = do
- snap <- $(loadSnapTH 'applicationInitializer 'site)
+ -- 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
+#else
+main = quickHttpServe applicationInitializer site
#endif
diff --git a/project_template/default/src/Site.hs
b/project_template/default/src/Site.hs
index e60c894..b59f647 100644
--- a/project_template/default/src/Site.hs
+++ b/project_template/default/src/Site.hs
@@ -31,7 +31,7 @@ import Application
index :: Application ()
index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"
where
- indexSplices =
+ indexSplices =
[ ("start-time", startTimeSplice)
, ("current-time", currentTimeSplice)
]
diff --git a/snap.cabal b/snap.cabal
index 3826833..f9916e9 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -43,7 +43,8 @@ Library
other-modules:
Snap.Extension.Loader.Devel.Evaluator,
- Snap.Extension.Loader.Devel.Signal
+ Snap.Extension.Loader.Devel.Signal,
+ Snap.Extension.Loader.Devel.TreeWatcher
build-depends:
base >= 4 && < 5,
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 7111da9..1afd29b 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -9,6 +9,8 @@ module Snap.Extension.Loader.Devel
( loadSnapTH
) where
+import Control.Monad (liftM2)
+
import Data.List (groupBy, intercalate, isPrefixOf, nub)
import Data.Maybe (catMaybes)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
@@ -25,6 +27,7 @@ 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
------------------------------------------------------------------------------
-- | This function derives all the information necessary to use the
@@ -33,20 +36,15 @@ import Snap.Extension.Loader.Devel.Evaluator
--
-- This could be considered a TH wrapper around a function
--
--- > loadSnap :: Initializer s -> SnapExtend s () -> IO (Snap ())
+-- > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ())
--
-- with a magical implementation.
--
--- The returned Snap action runs the 'Initializer', runs the 'Snap' handler,
--- and does the cleanup. This means that the whole application state will be
--- loaded and unloaded for each request. To make this worthwhile, those steps
--- should be made quite fast.
---
-- The upshot is that you shouldn't need to recompile your server
-- during development unless your .cabal file changes, or the code
-- that uses this splice changes.
-loadSnapTH :: Name -> Name -> Q Exp
-loadSnapTH initializer action = do
+loadSnapTH :: Name -> Name -> [String] -> Q Exp
+loadSnapTH initializer action additionalWatchDirs = do
args <- runIO getArgs
let initMod = nameModule initializer
@@ -54,14 +52,15 @@ loadSnapTH initializer action = do
actMod = nameModule action
actBase = nameBase action
- modules = catMaybes [initMod, actMod]
opts = getHintOpts args
+ modules = catMaybes [initMod, actMod]
+ srcPaths = additionalWatchDirs ++ getSrcPaths args
-- 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 initBase actBase |]
+ in hintSnap opts modules srcPaths initBase actBase |]
------------------------------------------------------------------------------
@@ -90,6 +89,14 @@ getHintOpts args = removeBad opts
------------------------------------------------------------------------------
+-- | This function extracts the source paths from the compilation args
+getSrcPaths :: [String] -> [String]
+getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg
+ where
+ srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)
+
+
+------------------------------------------------------------------------------
-- | This function creates the Snap handler that actually is
-- responsible for doing the dynamic loading of actions via hint,
-- given all of the configuration information that the interpreter
@@ -97,12 +104,6 @@ getHintOpts args = removeBad opts
-- and caches the interpreter results for a short time before allowing
-- it to run again.
--
--- This constructs an expression of type Snap (), that is essentially
---
--- > bracketSnap initialization cleanup handler
---
--- for the values of initialization, cleanup, and handler passed in.
---
-- Generally, this won't be called manually. Instead, loadSnapTH will
-- generate a call to it at compile-time, calculating all the
-- arguments from its environment.
@@ -112,36 +113,41 @@ 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 paths to watch for updates
-> String -- ^ The name of the initializer action
-> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
-hintSnap opts modules initialization handler = do
- let action = intercalate " " [ "runInitializerWithoutReloadAction"
- , initialization
- , handler
- ]
- interpreter = do
- loadModules . nub $ modules
- let imports = "Prelude" :
- "Snap.Extension" :
- "Snap.Types" :
- modules
- setImports . nub $ imports
-
- interpret action (as :: HintLoadable)
-
- loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
-
- formatOnError (Left err) = error $ format err
- formatOnError (Right a) = a
-
- loader = formatOnError `fmap` protectHandlers loadInterpreter
-
- test prevTime = do
- now <- getCurrentTime
- return $ diffUTCTime now prevTime < 4
-
- protectedHintEvaluator getCurrentTime test loader
+hintSnap opts modules srcPaths initialization handler =
+ protectedHintEvaluator initialize test loader
+ where
+ action = intercalate " " [ "runInitializerWithoutReloadAction"
+ , initialization
+ , handler
+ ]
+ interpreter = do
+ loadModules . nub $ modules
+ let imports = "Prelude" :
+ "Snap.Extension" :
+ "Snap.Types" :
+ modules
+ setImports . nub $ imports
+
+ interpret action (as :: HintLoadable)
+
+ loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
+
+ formatOnError (Left err) = error $ format err
+ formatOnError (Right a) = a
+
+ loader = formatOnError `fmap` protectHandlers loadInterpreter
+
+ initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths
+
+ test (prevTime, ts) = do
+ now <- getCurrentTime
+ if diffUTCTime now prevTime < 3
+ then return True
+ else checkTreeStatus ts
------------------------------------------------------------------------------
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
index b62762c..01b1c16 100644
--- a/src/Snap/Extension/Loader/Devel/Evaluator.hs
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -38,7 +38,7 @@ type HintLoadable = IO (Snap (), IO ())
--
-- 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.
+-- before the recompile condition is reached.
protectedHintEvaluator :: forall a.
IO a
-> (a -> IO Bool)
diff --git a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs
b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs
new file mode 100644
index 0000000..afdcaaf
--- /dev/null
+++ b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs
@@ -0,0 +1,46 @@
+module Snap.Extension.Loader.Devel.TreeWatcher
+ ( TreeStatus
+ , getTreeStatus
+ , checkTreeStatus
+ ) where
+
+import Control.Applicative
+
+import System.Directory
+import System.Directory.Tree
+
+import System.Time
+
+
+------------------------------------------------------------------------------
+-- | An opaque representation of the contents and last modification
+-- times of a forest of directory trees.
+data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]
+
+
+------------------------------------------------------------------------------
+-- | Create a 'TreeStatus' for later checking with 'checkTreeStatus'
+getTreeStatus :: [FilePath] -> IO TreeStatus
+getTreeStatus = liftA2 (<$>) TS readModificationTimes
+
+
+------------------------------------------------------------------------------
+-- | Checks that all the files present in the initial set of paths are
+-- the exact set of files currently present, with unchanged modifcations times
+checkTreeStatus :: TreeStatus -> IO Bool
+checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths
+ where
+ check = and . zipWith adtEq entries
+ adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2
+
+ dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2)
+ dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2
+ dtEq _ _ = False
+
+
+------------------------------------------------------------------------------
+-- | This is the core of the functions in this module. It converts a
+-- list of filepaths into a list of 'AnchoredDirTree' annotated with
+-- the modification times of the files located in those paths.
+readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]
+readModificationTimes = mapM $ readDirectoryWith getModificationTime
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
