snap-loader-dynamic 0.9.0.1 → 1.0.0.2
raw patch · 6 files changed
Files
- README.md +5/−5
- snap-loader-dynamic.cabal +31/−15
- src/Snap/Loader/Dynamic.hs +50/−21
- src/Snap/Loader/Dynamic/Evaluator.hs +16/−16
- src/Snap/Loader/Dynamic/Signal.hs +8/−10
- src/Snap/Loader/Dynamic/TreeWatcher.hs +17/−0
README.md view
@@ -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/.+[](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/`.-
snap-loader-dynamic.cabal view
@@ -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
src/Snap/Loader/Dynamic.hs view
@@ -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
src/Snap/Loader/Dynamic/Evaluator.hs view
@@ -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
src/Snap/Loader/Dynamic/Signal.hs view
@@ -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 ------------------------------------------------------------------------------
src/Snap/Loader/Dynamic/TreeWatcher.hs view
@@ -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