diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,6 @@ +Ozgun Ataman +Doug Beardsley +Gregory Collins +Carl Howells +Chris Smith +Jurriën Stutterheim diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.SNAP.md b/README.SNAP.md new file mode 100644 --- /dev/null +++ b/README.SNAP.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/`. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/snap-loader-dynamic.cabal b/snap-loader-dynamic.cabal new file mode 100644 --- /dev/null +++ b/snap-loader-dynamic.cabal @@ -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 + diff --git a/src/Snap/Loader/Dynamic.hs b/src/Snap/Loader/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Dynamic.hs @@ -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) diff --git a/src/Snap/Loader/Dynamic/Evaluator.hs b/src/Snap/Loader/Dynamic/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Dynamic/Evaluator.hs @@ -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 () diff --git a/src/Snap/Loader/Dynamic/Signal.hs b/src/Snap/Loader/Dynamic/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Dynamic/Signal.hs @@ -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 +------------------------------------------------------------------------------ diff --git a/src/Snap/Loader/Dynamic/TreeWatcher.hs b/src/Snap/Loader/Dynamic/TreeWatcher.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Dynamic/TreeWatcher.hs @@ -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