happstack-plugins 6.0.2 → 6.0.3
raw patch · 3 files changed
+117/−36 lines, 3 filesdep ~happstack-serverdep ~hinotify
Dependency ranges changed: happstack-server, hinotify
Files
- Happstack/Plugins/Dynamic.hs +2/−3
- Happstack/Plugins/Plugins.hs +112/−30
- happstack-plugins.cabal +3/−3
Happstack/Plugins/Dynamic.hs view
@@ -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))
Happstack/Plugins/Plugins.hs view
@@ -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)+ +
happstack-plugins.cabal view
@@ -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