snap-loader-dynamic (empty) → 0.9.0
raw patch · 10 files changed
+602/−0 lines, 10 filesdep +basedep +directorydep +directory-treesetup-changed
Dependencies added: base, directory, directory-tree, hint, mtl, old-time, snap-core, template-haskell, time, unix
Files
- CONTRIBUTORS +6/−0
- LICENSE +27/−0
- README.SNAP.md +42/−0
- README.md +32/−0
- Setup.hs +3/−0
- snap-loader-dynamic.cabal +56/−0
- src/Snap/Loader/Dynamic.hs +199/−0
- src/Snap/Loader/Dynamic/Evaluator.hs +140/−0
- src/Snap/Loader/Dynamic/Signal.hs +57/−0
- src/Snap/Loader/Dynamic/TreeWatcher.hs +40/−0
+ CONTRIBUTORS view
@@ -0,0 +1,6 @@+Ozgun Ataman <ozataman@gmail.com>+Doug Beardsley <mightybyte@gmail.com>+Gregory Collins <greg@gregorycollins.net>+Carl Howells <chowells79@gmail.com>+Chris Smith <cdsmith@gmail.com>+Jurriën Stutterheim <j.stutterheim@me.com>
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the Snap Framework authors nor the names of its+contributors may be used to endorse or promote products derived from this+software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.SNAP.md view
@@ -0,0 +1,42 @@+Snap Framework+--------------++Snap is a simple and fast web development framework and server written in+Haskell. For more information or to download the latest version, you can visit+the Snap project website at http://snapframework.com/.+++Snap Status and Features+------------------------++The Snap core system consists of:++ * a high-speed HTTP server, with an optional high-concurrency backend using+ the [libev](http://software.schmorp.de/pkg/libev.html) library++ * a sensible and clean monad for web programming++ * an xml-based templating system for generating HTML that allows you to bind+ Haskell functionality to XML tags without getting PHP-style tag soup all+ over your pants++ * a "snaplet" system for building web sites from composable pieces.++Snap is currently only officially supported on Unix platforms; it has been+tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows.+++Snap Philosophy+---------------++Snap aims to be the *de facto* web toolkit for Haskell, on the basis of:++ * High performance++ * High design standards++ * Simplicity and ease of use, even for Haskell beginners++ * Excellent documentation++ * Robustness and high test coverage
+ README.md view
@@ -0,0 +1,32 @@+Snap Framework+==============++Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by+Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more+information about Snap, read the `README.SNAP.md` or visit the Snap project+website at http://www.snapframework.com/.++## Library contents++This is utility project for the Snap Framework, which contains a+library allowing Snap applications to recompile actions on the fly in+development mode.++Building snap-loader-dynamic+============================++This library is built using+[Cabal](http://www.haskell.org/cabal/) and+[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run++ cabal install++from the `snap-loader-dynamic` toplevel directory.+++## Building the Haddock Documentation++The haddock documentation can be built using 'cabal haddock'.++The docs get put in `dist/doc/html/`.+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ snap-loader-dynamic.cabal view
@@ -0,0 +1,56 @@+name: snap-loader-dynamic+version: 0.9.0+synopsis: Snap: A Haskell Web Framework: dynamic loader+description: Snap Framework dynamic loader+license: BSD3+license-file: LICENSE+author: Carl Howells+maintainer: snap@snapframework.com+build-type: Simple+cabal-version: >= 1.8+homepage: http://snapframework.com/+category: Web, Snap++extra-source-files:+ CONTRIBUTORS,+ LICENSE,+ README.md,+ README.SNAP.md++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Loader.Dynamic++ other-modules:+ Snap.Loader.Dynamic.Evaluator,+ Snap.Loader.Dynamic.Signal,+ Snap.Loader.Dynamic.TreeWatcher++ build-depends:+ hint >= 0.3.3.1 && < 0.4,+ old-time >= 1.0 && < 1.2,+ base >= 4 && < 5,+ directory >= 1.0 && < 1.2,+ directory-tree >= 0.10 && < 0.11,+ mtl > 2.0 && < 2.2,+ snap-core >= 0.9 && < 0.10,+ time >= 1.1 && < 1.5,+ template-haskell >= 2.2 && < 2.8++ if !os(windows)+ build-depends:+ unix >= 2.2.0.0 && < 2.6++ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ -fno-warn-orphans -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ -fno-warn-orphans++source-repository head+ type: git+ location: git://github.com/snapframework/snap-loader-dynamic.git+
+ src/Snap/Loader/Dynamic.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TemplateHaskell #-}++------------------------------------------------------------------------------+-- | This module includes the machinery necessary to use hint to load+-- action code dynamically. It includes a Template Haskell function+-- to gather the necessary compile-time information about code+-- location, compiler arguments, etc, and bind that information into+-- the calls to the dynamic loader.+module Snap.Loader.Dynamic+ ( loadSnapTH+ ) where++------------------------------------------------------------------------------+import Control.Monad (liftM2)+import Data.Char (isAlphaNum)+import Data.List+import Data.Maybe (maybeToList)+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import Data.Typeable+import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf)+import Language.Haskell.Interpreter.Unsafe+import Language.Haskell.TH+import System.Environment (getArgs)+import Snap.Core+import Snap.Loader.Dynamic.Signal+import Snap.Loader.Dynamic.Evaluator+import Snap.Loader.Dynamic.TreeWatcher+++------------------------------------------------------------------------------+-- | This function derives all the information necessary to use the interpreter+-- from the compile-time environment, and compiles it in to the generated code.+--+-- This could be considered a TH wrapper around a function+--+-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))+-- > -> [String] -> IO (a, Snap (), IO ())+--+-- with a magical implementation. The [String] argument is a list of+-- directories to watch for updates to trigger a reloading. Directories+-- containing code should be automatically picked up by this splice.+--+-- The generated splice executes the initialiser once, sets up the interpreter+-- for the load function, and returns the initializer's result along with the+-- interpreter's proxy handler and cleanup actions. The behavior of the proxy+-- actions will change to reflect changes in the watched files, reinterpreting+-- the load function as needed and applying it to the initializer result.+--+-- This will handle reloading the application successfully in most cases. The+-- cases in which it is certain to fail are those involving changing the types+-- of the initializer or the load function, or changing the compiler options+-- required, such as by changing/adding dependencies in the project's .cabal+-- file. In those cases, a full recompile will be needed.+--+loadSnapTH :: Q Exp -- ^ the initializer expression+ -> Name -- ^ the name of the load function+ -> [String] -- ^ a list of directories to watch in addition+ -- to those containing code+ -> Q Exp+loadSnapTH initializer action additionalWatchDirs = do+ args <- runIO getArgs++ let opts = getHintOpts args+ srcPaths = additionalWatchDirs ++ getSrcPaths args++ -- The first line is an extra type check to ensure the arguments+ -- provided have the the correct types+ [| do let _ = $initializer >>= $(varE action)+ v <- $initializer+ (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v+ return (v, handler, cleanup) |]+ where+ actMods = maybeToList $ nameModule action+ loadStr = nameBase action+++------------------------------------------------------------------------------+-- | Convert the command-line arguments passed in to options for the+-- hint interpreter. This is somewhat brittle code, based on a few+-- experimental datapoints regarding the structure of the command-line+-- arguments cabal produces.+getHintOpts :: [String] -> [String]+getHintOpts args = removeBad opts+ where+ --------------------------------------------------------------------------+ bad = ["-threaded", "-O", "-main-is"]++ --------------------------------------------------------------------------+ removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)++ --------------------------------------------------------------------------+ hideAll = filter (== "-hide-all-packages") args++ --------------------------------------------------------------------------+ srcOpts = filter (\x -> "-i" `isPrefixOf` x+ && not ("-idist" `isPrefixOf` x))+ args++ --------------------------------------------------------------------------+ toCopy = filter (not . isSuffixOf ".hs") $+ dropWhile (not . ("-package" `isPrefixOf`)) args++ --------------------------------------------------------------------------+ copy = map (intercalate " ")+ . groupBy (\_ s -> not $ "-" `isPrefixOf` s)++ --------------------------------------------------------------------------+ opts = concat [hideAll, srcOpts, copy toCopy]+++------------------------------------------------------------------------------+-- | 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 needs. It also ensures safe+-- concurrent access to the interpreter, and caches the interpreter results for+-- a short time before allowing it to run again.+--+-- 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.+--+hintSnap :: Typeable a+ => [String]+ -- ^ A list of command-line options for the interpreter+ -> [String]+ -- ^ A list of modules that need to be interpreted. This should+ -- contain only the 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 function to load+ -> a+ -- ^ The value to apply the loaded function to+ -> IO (Snap (), IO ())+hintSnap opts modules srcPaths action value =+ protectedHintEvaluator initialize test loader++ where+ --------------------------------------------------------------------------+ witness x = undefined $ x `asTypeOf` value :: HintLoadable++ --------------------------------------------------------------------------+ -- This is somewhat fragile, and probably can be cleaned up with a future+ -- version of Typeable. For the moment, and backwards-compatibility, this+ -- is the approach being taken.+ witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) .+ filter (elem '.') . groupBy typePart . show . typeOf $+ witness++ --------------------------------------------------------------------------+ typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.'++ --------------------------------------------------------------------------+ interpreter = do+ loadModules . nub $ modules+ setImports . nub $ "Prelude" : witnessModules ++ modules++ f <- interpret action witness+ return $ f value++ --------------------------------------------------------------------------+ 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+++------------------------------------------------------------------------------+-- | Convert an InterpreterError to a String for presentation+format :: InterpreterError -> String+format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e+format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e+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)
+ src/Snap/Loader/Dynamic/Evaluator.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Loader.Dynamic.Evaluator+ ( HintLoadable+ , protectedHintEvaluator+ ) where++------------------------------------------------------------------------------+import Control.Exception+import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Control.Concurrent (ThreadId, forkIO, myThreadId)+import Control.Concurrent.MVar+import Prelude hiding (catch, init, any)+import Snap.Core (Snap)+++------------------------------------------------------------------------------+-- | A type synonym to simply talking about the type loaded by hint.+type HintLoadable = IO (Snap (), IO ())+++------------------------------------------------------------------------------+-- | Convert an action to generate 'HintLoadable's into Snap and IO actions+-- that handle periodic reloading. The resulting action will share initialized+-- state until the next execution of the input action. At this time, the+-- cleanup action will be executed.+--+-- The first two arguments control when recompiles are done. The first argument+-- is an action that is executed when compilation starts. The second is a+-- function from the result of the first action to an action that determines+-- whether the value from the previous compilation is still good. This+-- abstracts out the strategy for determining when a cached result is no longer+-- valid.+--+-- 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+-- recompile condition is reached.+protectedHintEvaluator :: forall a.+ IO a+ -> (a -> IO Bool)+ -> IO HintLoadable+ -> 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 successful result.+ readerContainer <- newReaderContainer++ -- 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.+ resultContainer <- newResultContainer++ -- 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.+ 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, _) -> 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 []++ newResultContainer :: IO (MVar (Maybe (Either SomeException+ (Snap (), IO ()), a)))+ newResultContainer = newMVar Nothing++ cleanup (Just (Right (_, clean), _)) = clean+ cleanup _ = return ()
+ src/Snap/Loader/Dynamic/Signal.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+module Snap.Loader.Dynamic.Signal (protectHandlers) where++------------------------------------------------------------------------------+import Control.Exception (bracket)+++#ifdef mingw32_HOST_OS++ -------------+ -- windows --+ -------------+------------------------------------------------------------------------------+import GHC.ConsoleHandler as C++saveHandlers :: IO C.Handler+saveHandlers = C.installHandler Ignore++restoreHandlers :: C.Handler -> IO C.Handler+restoreHandlers = C.installHandler+------------------------------------------------------------------------------+++#else++ -----------+ -- posix --+ -----------+------------------------------------------------------------------------------+import qualified System.Posix.Signals as S++helper :: S.Handler -> S.Signal -> IO S.Handler+helper handler signal = S.installHandler signal handler Nothing++signals :: [S.Signal]+signals = [ S.sigQUIT+ , S.sigINT+ , S.sigHUP+ , S.sigTERM+ ]++saveHandlers :: IO [S.Handler]+saveHandlers = mapM (helper S.Ignore) signals++restoreHandlers :: [S.Handler] -> IO [S.Handler]+restoreHandlers h = sequence $ zipWith helper h signals+------------------------------------------------------------------------------++#endif++ ----------+ -- both --+ ----------+------------------------------------------------------------------------------+protectHandlers :: IO a -> IO a+protectHandlers a = bracket saveHandlers restoreHandlers $ const a+------------------------------------------------------------------------------
+ src/Snap/Loader/Dynamic/TreeWatcher.hs view
@@ -0,0 +1,40 @@+module Snap.Loader.Dynamic.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 (==) entries+++------------------------------------------------------------------------------+-- | 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