snap-loader-dynamic-0.10/0000755000000000000000000000000012061210254013440 5ustar0000000000000000snap-loader-dynamic-0.10/README.md0000644000000000000000000000157112061210254014723 0ustar0000000000000000Snap 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/`. snap-loader-dynamic-0.10/CONTRIBUTORS0000644000000000000000000000034212061210254015317 0ustar0000000000000000Ozgun Ataman Doug Beardsley Gregory Collins Carl Howells Chris Smith Jurriën Stutterheim snap-loader-dynamic-0.10/LICENSE0000644000000000000000000000274512061210254014455 0ustar0000000000000000Copyright (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. snap-loader-dynamic-0.10/Setup.hs0000644000000000000000000000005712061210254015076 0ustar0000000000000000import Distribution.Simple main = defaultMain snap-loader-dynamic-0.10/snap-loader-dynamic.cabal0000644000000000000000000000334312061210254020256 0ustar0000000000000000name: snap-loader-dynamic version: 0.10 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: base >= 4 && < 5, directory-tree >= 0.10 && < 0.12, mtl > 2.0 && < 2.2, snap-core >= 0.9 && < 0.11, time >= 1.1 && < 1.5, template-haskell >= 2.2 && < 2.9 if impl(ghc >= 7.2.0) build-depends: hint >= 0.3.3.1 && < 0.4 else build-depends: hint >= 0.3.3.1 && < 0.3.3.5 if impl(ghc >= 7.6.0) build-depends: directory >= 1.2 && < 1.3 else build-depends: directory >= 1.0 && < 1.3, old-time >= 1.0 && < 1.2 if !os(windows) build-depends: unix >= 2.2.0.0 && < 2.7 extensions: CPP 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 snap-loader-dynamic-0.10/README.SNAP.md0000644000000000000000000000227312061210254015463 0ustar0000000000000000Snap 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 snap-loader-dynamic-0.10/src/0000755000000000000000000000000012061210254014227 5ustar0000000000000000snap-loader-dynamic-0.10/src/Snap/0000755000000000000000000000000012061210254015130 5ustar0000000000000000snap-loader-dynamic-0.10/src/Snap/Loader/0000755000000000000000000000000012061210254016336 5ustar0000000000000000snap-loader-dynamic-0.10/src/Snap/Loader/Dynamic.hs0000644000000000000000000002151212061210254020257 0ustar0000000000000000{-# 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", "-o", "--make"] -------------------------------------------------------------------------- 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" : "Snap.Core" : 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) snap-loader-dynamic-0.10/src/Snap/Loader/Dynamic/0000755000000000000000000000000012061210254017722 5ustar0000000000000000snap-loader-dynamic-0.10/src/Snap/Loader/Dynamic/Signal.hs0000644000000000000000000000351312061210254021475 0ustar0000000000000000{-# 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 ------------------------------------------------------------------------------ snap-loader-dynamic-0.10/src/Snap/Loader/Dynamic/TreeWatcher.hs0000644000000000000000000000365112061210254022500 0ustar0000000000000000module Snap.Loader.Dynamic.TreeWatcher ( TreeStatus , getTreeStatus , checkTreeStatus ) where #ifndef MIN_VERSION_directory #define MIN_VERSION_directory(x,y,z) 1 #endif ------------------------------------------------------------------------------ import Control.Applicative import System.Directory import System.Directory.Tree #if MIN_VERSION_directory(1,2,0) import Data.Time.Clock #else import System.Time #endif ------------------------------------------------------------------------------ -- | An opaque representation of the contents and last modification -- times of a forest of directory trees. #if MIN_VERSION_directory(1,2,0) data TreeStatus = TS [FilePath] [AnchoredDirTree UTCTime] #else data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime] #endif ------------------------------------------------------------------------------ -- | 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. #if MIN_VERSION_directory(1,2,0) readModificationTimes :: [FilePath] -> IO [AnchoredDirTree UTCTime] #else readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime] #endif readModificationTimes = mapM $ readDirectoryWith getModificationTime snap-loader-dynamic-0.10/src/Snap/Loader/Dynamic/Evaluator.hs0000644000000000000000000001374212061210254022227 0ustar0000000000000000{-# 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 ()