diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,12 @@ 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/. +[![Build Status](https://travis-ci.org/snapframework/snap-loader-dynamic.svg?branch=master)](https://travis-ci.org/snapframework/snap-loader-dynamic) +Snap is a simple and fast web development framework and server written in +Haskell. 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 @@ -29,4 +30,3 @@ The haddock documentation can be built using 'cabal haddock'. The docs get put in `dist/doc/html/`. - diff --git a/snap-loader-dynamic.cabal b/snap-loader-dynamic.cabal --- a/snap-loader-dynamic.cabal +++ b/snap-loader-dynamic.cabal @@ -1,15 +1,16 @@ name: snap-loader-dynamic -version: 0.9.0.1 -synopsis: Snap: A Haskell Web Framework: dynamic loader -description: Snap Framework dynamic loader +version: 1.0.0.2 +synopsis: Snap dynamic loader +description: Snap Framework dynamic code loader for development mode license: BSD3 license-file: LICENSE author: Carl Howells maintainer: snap@snapframework.com build-type: Simple -cabal-version: >= 1.8 +cabal-version: >= 1.10 homepage: http://snapframework.com/ category: Web, Snap +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.2 extra-source-files: CONTRIBUTORS, @@ -18,6 +19,7 @@ README.SNAP.md Library + default-language: Haskell2010 hs-source-dirs: src exposed-modules: @@ -29,25 +31,39 @@ 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 + directory-tree >= 0.10 && < 0.13, + mtl > 2.0 && < 2.3, + snap-core >= 1.0 && < 1.1, + time >= 1.1 && < 1.10, + template-haskell >= 2.2 && < 3 + if impl(ghc >= 7.2.0) + build-depends: + hint >= 0.3.3.1 && < 0.10 + else + build-depends: + hint >= 0.3.3.1 && < 0.3.3.5 + + if impl(ghc >= 7.6.0) + build-depends: + directory >= 1.2 && < 1.4 + else + build-depends: + directory >= 1.0 && < 1.4, + old-time >= 1.0 && < 1.2 + if !os(windows) build-depends: - unix >= 2.2.0.0 && < 2.6 + unix >= 2.2.0.0 && < 2.8 + default-extensions: CPP + if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans source-repository head diff --git a/src/Snap/Loader/Dynamic.hs b/src/Snap/Loader/Dynamic.hs --- a/src/Snap/Loader/Dynamic.hs +++ b/src/Snap/Loader/Dynamic.hs @@ -11,13 +11,16 @@ ) where ------------------------------------------------------------------------------ -import Control.Monad (liftM2) +import Control.Concurrent +import Control.Monad (liftM2, forever) +#if !MIN_VERSION_base(4,7,0) import Data.Char (isAlphaNum) +#endif 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 hiding (lift, typeOf) import Language.Haskell.Interpreter.Unsafe import Language.Haskell.TH import System.Environment (getArgs) @@ -83,7 +86,7 @@ getHintOpts args = removeBad opts where -------------------------------------------------------------------------- - bad = ["-threaded", "-O", "-main-is", "-o"] + bad = ["-threaded", "-O", "-main-is", "-o", "--make", "-static", "-XHaskell", "-ddump-hi"] -------------------------------------------------------------------------- removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) @@ -92,9 +95,7 @@ hideAll = filter (== "-hide-all-packages") args -------------------------------------------------------------------------- - srcOpts = filter (\x -> "-i" `isPrefixOf` x - && not ("-idist" `isPrefixOf` x)) - args + srcOpts = filter (\x -> "-i" `isPrefixOf` x) args -------------------------------------------------------------------------- toCopy = filter (not . isSuffixOf ".hs") $ @@ -142,14 +143,31 @@ -> a -- ^ The value to apply the loaded function to -> IO (Snap (), IO ()) -hintSnap opts modules srcPaths action value = - protectedHintEvaluator initialize test loader - +hintSnap opts modules srcPaths action value = do + load <- runInterpreterThread + protectedHintEvaluator getCurrentState testState load where -------------------------------------------------------------------------- witness x = undefined $ x `asTypeOf` value :: HintLoadable +#if MIN_VERSION_base(4,7,0) -------------------------------------------------------------------------- + witnessModules = filter (`notElem` inPrelude) . map dropInternal . + map tyConModule . tyCons . typeOf $ witness + + -------------------------------------------------------------------------- + inPrelude = ["GHC.Prim", "GHC.Types", "GHC.Tuple"] + + -------------------------------------------------------------------------- + tyCons x = let (c, rs) = splitTyConApp x in c : concatMap tyCons rs + + -------------------------------------------------------------------------- + dropInternal s = case stripPrefix "Snap.Internal." s of + Nothing -> s + Just "Types" -> "Snap.Core" + Just x -> "Snap." ++ x +#else + -------------------------------------------------------------------------- -- 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. @@ -159,30 +177,41 @@ -------------------------------------------------------------------------- typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.' +#endif -------------------------------------------------------------------------- - interpreter = do - loadModules . nub $ modules - setImports . nub $ "Prelude" : "Snap.Core" : witnessModules ++ modules + runInterpreterThread = do + input <- newEmptyMVar + output <- newEmptyMVar + + forkIO . forever $ do + restore <- protectHandlers + err <- unsafeRunInterpreterWithArgs opts $ do + liftIO $ restore + forever $ do + liftIO $ takeMVar input - f <- interpret action witness - return $ f value + loadModules . nub $ modules + setImports . nub $ "Prelude" : "Snap.Core" : + witnessModules ++ modules + f <- interpret action witness - -------------------------------------------------------------------------- - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter + liftIO . putMVar output $ f value + reset + putMVar output $ formatOnError err + + return $ putMVar input () >> takeMVar output + -------------------------------------------------------------------------- formatOnError (Left err) = error $ format err formatOnError (Right a) = a -------------------------------------------------------------------------- - loader = formatOnError `fmap` protectHandlers loadInterpreter - - -------------------------------------------------------------------------- - initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths + getCurrentState = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths -------------------------------------------------------------------------- - test (prevTime, ts) = do + testState (prevTime, ts) = do now <- getCurrentTime if diffUTCTime now prevTime < 3 then return True diff --git a/src/Snap/Loader/Dynamic/Evaluator.hs b/src/Snap/Loader/Dynamic/Evaluator.hs --- a/src/Snap/Loader/Dynamic/Evaluator.hs +++ b/src/Snap/Loader/Dynamic/Evaluator.hs @@ -6,12 +6,11 @@ ) where ------------------------------------------------------------------------------ -import Control.Exception +import qualified Control.Exception as Ex 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) @@ -75,32 +74,33 @@ -- previous state, if there was any, and then begin -- evaluation of the new code and state. when (null readers) $ do - let runAndFill = block $ do + let runAndFill = Ex.mask $ \unmask -> do -- run the cleanup action previous <- readMVar resultContainer - unblock $ cleanup previous + unmask $ cleanup previous -- compile the new internals and initialize - stateInitializer <- unblock getInternals - res <- unblock stateInitializer + stateInitializer <- unmask getInternals + res <- unmask stateInitializer let a = fst res - clearAndNotify (Right res) + clearAndNotify unmask (Right res) (flip putMVar a . snd) - killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) - throwIO e + killWaiting :: Ex.SomeException -> IO () + killWaiting e = Ex.mask $ \unmask -> do + clearAndNotify unmask (Left e) + (flip Ex.throwTo e . fst) + Ex.throwIO e - clearAndNotify r f = do - a <- unblock start + clearAndNotify unmask r f = do + a <- unmask start _ <- swapMVar resultContainer $ Just (r, a) allReaders <- swapMVar readerContainer [] mapM_ f allReaders - _ <- forkIO $ runAndFill `catch` killWaiting + _ <- forkIO $ runAndFill `Ex.catch` killWaiting return () -- Wait for the evaluation of the action to complete, @@ -115,7 +115,7 @@ valid <- test a case (valid, res) of (True, Right (x, _)) -> return x - (True, Left e) -> throwIO e + (True, Left e) -> Ex.throwIO e (False, _) -> waitForNewResult Nothing -> waitForNewResult getResult @@ -132,7 +132,7 @@ newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))]) newReaderContainer = newMVar [] - newResultContainer :: IO (MVar (Maybe (Either SomeException + newResultContainer :: IO (MVar (Maybe (Either Ex.SomeException (Snap (), IO ()), a))) newResultContainer = newMVar Nothing diff --git a/src/Snap/Loader/Dynamic/Signal.hs b/src/Snap/Loader/Dynamic/Signal.hs --- a/src/Snap/Loader/Dynamic/Signal.hs +++ b/src/Snap/Loader/Dynamic/Signal.hs @@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} module Snap.Loader.Dynamic.Signal (protectHandlers) where ------------------------------------------------------------------------------- -import Control.Exception (bracket) - - #ifdef mingw32_HOST_OS ------------- @@ -16,8 +12,8 @@ saveHandlers :: IO C.Handler saveHandlers = C.installHandler Ignore -restoreHandlers :: C.Handler -> IO C.Handler -restoreHandlers = C.installHandler +restoreHandlers :: C.Handler -> IO () +restoreHandlers h = C.installHandler h >> return () ------------------------------------------------------------------------------ @@ -42,8 +38,8 @@ saveHandlers :: IO [S.Handler] saveHandlers = mapM (helper S.Ignore) signals -restoreHandlers :: [S.Handler] -> IO [S.Handler] -restoreHandlers h = sequence $ zipWith helper h signals +restoreHandlers :: [S.Handler] -> IO () +restoreHandlers h = sequence_ $ zipWith helper h signals ------------------------------------------------------------------------------ #endif @@ -52,6 +48,8 @@ -- both -- ---------- ------------------------------------------------------------------------------ -protectHandlers :: IO a -> IO a -protectHandlers a = bracket saveHandlers restoreHandlers $ const a +protectHandlers :: IO (IO ()) +protectHandlers = do + h <- saveHandlers + return $ restoreHandlers h ------------------------------------------------------------------------------ diff --git a/src/Snap/Loader/Dynamic/TreeWatcher.hs b/src/Snap/Loader/Dynamic/TreeWatcher.hs --- a/src/Snap/Loader/Dynamic/TreeWatcher.hs +++ b/src/Snap/Loader/Dynamic/TreeWatcher.hs @@ -4,17 +4,30 @@ , 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 ------------------------------------------------------------------------------ @@ -36,5 +49,9 @@ -- | 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