diff --git a/Happstack/Plugins/Dynamic.hs b/Happstack/Plugins/Dynamic.hs --- a/Happstack/Plugins/Dynamic.hs +++ b/Happstack/Plugins/Dynamic.hs @@ -5,12 +5,11 @@ import Control.Concurrent.MVar (newMVar) import qualified Data.Map as Map -import Happstack.Plugins.Plugins (PluginHandle(..)) -import System.INotify (initINotify) +import Happstack.Plugins.Plugins (PluginHandle(..),initPersistentINotify) -- |initialize the plugin system and return a 'PluginHandle' initPlugins :: IO PluginHandle initPlugins = - do inotify <- initINotify + do inotify <- initPersistentINotify objMap <- newMVar Map.empty return (PluginHandle (inotify, objMap)) diff --git a/Happstack/Plugins/Plugins.hs b/Happstack/Plugins/Plugins.hs --- a/Happstack/Plugins/Plugins.hs +++ b/Happstack/Plugins/Plugins.hs @@ -5,10 +5,12 @@ , funcTH , withIO , PluginHandle(..) + , initPersistentINotify ) where import Control.Applicative ((<$>)) -import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_) +import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_,newMVar) +import Control.Exception (bracketOnError) import Data.List (nub) import Data.Maybe (mapMaybe) import qualified Data.Map as Map @@ -17,7 +19,7 @@ import System.FilePath (addExtension, dropExtension) import System.Plugins.Load (Module, Symbol, LoadStatus(..), getImports, load, unloadAll) import System.Plugins.Make (Errors, MakeStatus(..), MakeCode(..), makeAll) -import System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..), addWatch, removeWatch) +import System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..), addWatch, removeWatch, initINotify) import System.FilePath (splitFileName) import Unsafe.Coerce (unsafeCoerce) @@ -31,17 +33,19 @@ fromSym :: Sym -> a fromSym = unsafeCoerce --- PluginHandle (iNotify, map of watched files) --- The map of watched files contains: --- ( WatchDescriptors of the file and its dependencies --- , dependencies of the file --- , errors when compiling the file if any --- , map of symbols defined in the file - this map contains: --- ( a function which reloads the symbol --- , the state of the symbol (probably the last call to the function in the first component) --- ) --- ) -newtype PluginHandle = PluginHandle (INotify, MVar (Map FilePath ([WatchDescriptor], [FilePath], Maybe Errors, Map Symbol (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))))) +newtype PluginHandle = PluginHandle + ( PersistentINotify -- Inotify handle + , MVar + ( Map FilePath -- source file being observed + ( [WatchDescriptorP] -- watch descriptor of the source file and its dependecies + , [FilePath] -- depedencies of the source file + , Maybe Errors -- errors when compiling the file if any + , Map Symbol -- symbol defined in the source file + (FilePath -> IO (Either Errors (Module, Sym)) -- function for reloading the symbol + , Either Errors (Module, Sym)) -- the state of the symbol (probably the result of the last call to the function in the first component) + ) + ) + ) funcTH :: PluginHandle -> Name -> IO (Either Errors a) @@ -71,15 +75,19 @@ do om <- readMVar objMap case Map.lookup fp om of Nothing -> - do addSymbol ph fp sym - rebuild ph fp True + do bracketOnError + (addSymbol ph fp sym) + (const$ deleteSymbol ph fp sym) + (const$ rebuild ph fp True) func ph fp sym (Just (_, _, Just errs, _)) -> return $ Left errs (Just (_, _, Nothing, symbols)) -> case Map.lookup sym symbols of Nothing -> - do addSymbol ph fp sym - rebuild ph fp True + do bracketOnError + (addSymbol ph fp sym) + (const$ deleteSymbol ph fp sym) + (const$ rebuild ph fp True) func ph fp sym (Just (_, Left errs)) -> return $ Left errs (Just (_, Right (_, dynSym))) -> return (Right $ fromSym dynSym) @@ -93,7 +101,7 @@ -> FilePath -- ^ source file to compile -> Bool -> IO () -rebuild p@(PluginHandle (inotify, objMap)) fp forceReload = +rebuild p@(PluginHandle (_inotify, objMap)) fp forceReload = do putStrLn ("Rebuilding " ++ fp) makeStatus <- makeAll fp ["-odir",".","-hidir",".","-o",replaceSuffix fp "o"] -- FIXME: allow user to specify additional flags, such as -O2 case makeStatus of @@ -116,9 +124,9 @@ Nothing -> return () (Just (oldWds, _, _, symbols)) -> do mapM_ unloadAll (unloadList symbols) - mapM_ (removeWatch inotify) oldWds + mapM_ removeWatchP oldWds res <- mapM (load' objFilePath) (Map.assocs symbols) - imports <- map (\bn -> addExtension bn ".hs") <$> getImports (dropExtension objFilePath) + imports <- map (\bn -> addExtension (mnameToPath bn) ".hs") <$> getImports (dropExtension objFilePath) wds <- observeFiles p fp imports modifyMVar_ objMap $ return . Map.insert fp (wds, [], Nothing, Map.fromList res) where @@ -138,19 +146,15 @@ (Right _) -> return () return (symbol, (reloader, r)) +mnameToPath :: FilePath -> FilePath +mnameToPath = replace '.' '/' + where replace x y = foldr (\a r -> if x==a then y:r else a:r) [] -observeFiles :: PluginHandle -> FilePath -> [FilePath] -> IO [WatchDescriptor] +observeFiles :: PluginHandle -> FilePath -> [FilePath] -> IO [WatchDescriptorP] observeFiles p@(PluginHandle (inotify,_objMap)) fp imports = mapM (\depFp -> do putStrLn ("Adding watch for: " ++ depFp) - let (d,f) = splitFileName depFp - addWatch inotify [Modify, Move, Delete] d $ \e -> - do putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) - case e of - Ignored -> return () - Deleted { filePath = f' } | f==f' -> rebuild p fp False - MovedIn { filePath = f' } | f==f' -> rebuild p fp False - Modified { maybeFilePath = Just f' } | f==f' -> rebuild p fp False - _ -> return () + let handler e = putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) >> rebuild p fp False + addWatchP inotify depFp handler ) (fp:imports) @@ -177,4 +181,82 @@ return () +deleteSymbol :: PluginHandle -> FilePath -> Symbol -> IO () +deleteSymbol (PluginHandle (_inotify, objMap)) sourceFP sym = + modifyMVar_ objMap $ \om -> + case Map.lookup sourceFP om of + Nothing -> return om + (Just (wds, deps, errs, symbols)) -> + let symbols' = Map.delete sym symbols + in return$ Map.insert sourceFP (wds, deps, errs, symbols') om + +-- Keeps watching a file even after it has been deleted and created again. +-- +-- It does so by observing the folder which contains the file. When no files +-- are observed in a given folder, the folder stops being observed. +data PersistentINotify = PersistentINotify + INotify -- INotify handle + (MVar + (Map FilePath -- Folder containing the file + ( WatchDescriptor -- Watch descriptor of the folder + , Map String -- File being observed + (Event -> IO ()) -- Handler to run on file events + ) + ) + ) + +data WatchDescriptorP = WatchDescriptorP PersistentINotify FilePath + +initPersistentINotify :: IO PersistentINotify +initPersistentINotify = do + iN <- initINotify + fmvar <- newMVar Map.empty + return$ PersistentINotify iN fmvar + +-- Replacement for splitFileName which returns "." instead of an empty folder. +splitFileName' :: FilePath -> (FilePath,String) +splitFileName' fp = + let (d,f) = splitFileName fp + in (if null d then "." else d,f) + +addWatchP :: PersistentINotify -> FilePath -> (Event -> IO ()) -> IO WatchDescriptorP +addWatchP piN@(PersistentINotify iN fmvar) fp hdl = + let (d,f) = splitFileName' fp + in modifyMVar fmvar$ \fm -> + case Map.lookup d fm of + Nothing -> do + wd <- addWatch iN [Modify, Move, Delete] d $ \e -> do + case e of + Ignored -> return () + Deleted { filePath = f' } -> callHandler e d f' + MovedIn { filePath = f' } -> callHandler e d f' + Modified { maybeFilePath = Just f' } -> callHandler e d f' + _ -> return () + return ( Map.insert d (wd,Map.singleton f hdl) fm + , WatchDescriptorP piN fp + ) + Just (wd,ffm) -> return ( Map.insert d (wd,Map.insert f hdl ffm) fm + , WatchDescriptorP piN fp + ) + where + callHandler e d f = do + fm <- readMVar fmvar + case Map.lookup d fm of + Nothing -> return () + Just (_,ffm) -> case Map.lookup f ffm of + Nothing -> return () + Just mhdl -> mhdl e + + +removeWatchP :: WatchDescriptorP -> IO () +removeWatchP (WatchDescriptorP (PersistentINotify iN fmvar) fp) = + let (d,f) = splitFileName' fp + in modifyMVar_ fmvar$ \fm -> + case Map.lookup d fm of + Nothing -> error$ "removeWatchP: invalid handle for file "++fp + Just (wd,ffm) -> let ffm' = Map.delete f ffm + in if Map.null ffm' then removeWatch wd >> return (Map.delete d fm) + else return (Map.insert d (wd,ffm') fm) + + diff --git a/happstack-plugins.cabal b/happstack-plugins.cabal --- a/happstack-plugins.cabal +++ b/happstack-plugins.cabal @@ -1,5 +1,5 @@ Name: happstack-plugins -Version: 6.0.2 +Version: 6.0.3 Synopsis: The haskell application server stack + reload Description: This library provides support for automatically recompiling and reloading modules into a running server. License: BSD3 @@ -34,8 +34,8 @@ build-depends: base >= 3 && < 5, containers, filepath, - happstack-server >= 6.0 && < 6.2, - hinotify, + happstack-server >= 6.0 && < 6.3, + hinotify >= 0.3.2, mtl, plugins >= 1.5.1.4, template-haskell