diff --git a/Happstack/Plugins/Dynamic.hs b/Happstack/Plugins/Dynamic.hs --- a/Happstack/Plugins/Dynamic.hs +++ b/Happstack/Plugins/Dynamic.hs @@ -1,15 +1,8 @@ module Happstack.Plugins.Dynamic - ( PluginHandle(..) + ( PluginHandle , initPlugins ) where -import Control.Concurrent.MVar (newMVar) -import qualified Data.Map as Map -import Happstack.Plugins.Plugins (PluginHandle(..),initPersistentINotify) +import Happstack.Plugins.Plugins (PluginHandle,initPlugins) --- |initialize the plugin system and return a 'PluginHandle' -initPlugins :: IO PluginHandle -initPlugins = - do inotify <- initPersistentINotify - objMap <- newMVar Map.empty - return (PluginHandle (inotify, objMap)) + diff --git a/Happstack/Plugins/FileSystemWatcher.hs b/Happstack/Plugins/FileSystemWatcher.hs new file mode 100644 --- /dev/null +++ b/Happstack/Plugins/FileSystemWatcher.hs @@ -0,0 +1,95 @@ +-- | Api for watching and notifying file changes. +-- Currently, this is based on inotify, but people may want to +-- provide implementations of this module for non-inotify-supported +-- platforms. +module Happstack.Plugins.FileSystemWatcher + ( FSWatcher + , FSWatchDescriptor + , initFSWatcher + , addWatch + , removeWatch + ) where + +import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_,newMVar) +import System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..),initINotify) +import qualified System.INotify as I(addWatch, removeWatch) +import System.FilePath (splitFileName) +import qualified Data.Map as Map +import Data.Map (Map) + +-- 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 FSWatcher = FSWatcher + 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 FSWatchDescriptor = FSWatchDescriptor FSWatcher FilePath + +-- | Initializes a watcher. +initFSWatcher :: IO FSWatcher +initFSWatcher = do + iN <- initINotify + fmvar <- newMVar Map.empty + return$ FSWatcher 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) + +-- | Runs the callback IO action on modifications to the file at the given path. +-- +-- Each file can have only one callback IO action. Registering a new IO action +-- discards any previously registered callback. +-- +-- The returned FSWatchDescriptor value can be used to stop watching the file. +addWatch :: FSWatcher -> FilePath -> IO () -> IO FSWatchDescriptor +addWatch piN@(FSWatcher iN fmvar) fp hdl = + let (d,f) = splitFileName' fp + in modifyMVar fmvar$ \fm -> + case Map.lookup d fm of + Nothing -> do + wd <- I.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 (const hdl)) fm + , FSWatchDescriptor piN fp + ) + Just (wd,ffm) -> return ( Map.insert d (wd,Map.insert f (const hdl) ffm) fm + , FSWatchDescriptor 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 + +-- | Stops watching the file associated to the given file descriptor. +removeWatch :: FSWatchDescriptor -> IO () +removeWatch (FSWatchDescriptor (FSWatcher _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 I.removeWatch wd >> return (Map.delete d fm) + else return (Map.insert d (wd,ffm') fm) + + diff --git a/Happstack/Plugins/Plugins.hs b/Happstack/Plugins/Plugins.hs --- a/Happstack/Plugins/Plugins.hs +++ b/Happstack/Plugins/Plugins.hs @@ -4,13 +4,17 @@ , func , funcTH , withIO - , PluginHandle(..) - , initPersistentINotify + , funcTH' + , withIO' + , PluginHandle + , initPlugins ) where import Control.Applicative ((<$>)) -import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_,newMVar) -import Control.Exception (bracketOnError) +import Control.Concurrent.MVar (MVar,readMVar,modifyMVar_,newMVar,modifyMVar) +import Control.Concurrent (threadDelay,killThread,ThreadId,forkIO) +import Control.Exception (bracketOnError,bracket) +import Control.Monad(when) import Data.List (nub) import Data.Maybe (mapMaybe) import qualified Data.Map as Map @@ -19,10 +23,10 @@ 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, initINotify) -import System.FilePath (splitFileName) import Unsafe.Coerce (unsafeCoerce) +import Happstack.Plugins.FileSystemWatcher + -- A very unsafe version of Data.Dynamic data Sym @@ -33,34 +37,76 @@ fromSym :: Sym -> a fromSym = unsafeCoerce -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) +data RecompilationState = RecompilationState + { rsRecompiling :: MVar Bool -- Is recompilation in progress? + , rsRecompilationNeeded :: MVar Bool -- Is recompilation needed? + , rsTimer :: Timer + } + +data PluginHandle = PluginHandle + { phWatcher :: FSWatcher -- Inotify handle + , phObjMap :: MVar + ( Map FilePath -- source file being observed + ( [FSWatchDescriptor] -- 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 + , Errors -- error from last recompilation attempt if any + , Maybe (Module, Sym) -- last succesfully loaded symbol ) - ) - ) + , RecompilationState + ) + ) + } +-- |initialize the plugin system and return a 'PluginHandle' +initPlugins :: IO PluginHandle +initPlugins = + do inotify <- initFSWatcher + objMap <- newMVar Map.empty + return$ PluginHandle inotify objMap + +newRecompilationState :: IO RecompilationState +newRecompilationState = do + recompiling <- newMVar False + recompilationNeeded <- newMVar False + timer <- newTimer + return RecompilationState + { rsRecompiling = recompiling + , rsRecompilationNeeded = recompilationNeeded + , rsTimer = timer + } + + funcTH :: PluginHandle -> Name -> IO (Either Errors a) -funcTH objMap name = +funcTH objMap name = fmap reformatOutput$ funcTH' objMap name [] + +funcTH' :: PluginHandle -> Name -> [String] -> IO (Errors,Maybe a) +funcTH' objMap name args = do let (fp, sym) = nameToFileSym name - func objMap fp sym + func' objMap fp sym args +reformatOutput :: (Errors,Maybe a) -> Either Errors a +reformatOutput ([],Just a) = Right a +reformatOutput ([],_) = Left ["Module not loaded."] +reformatOutput (errs,_) = Left errs + + withIO :: PluginHandle -> Name -> (a -> IO ()) -> IO () -withIO objMap name use = - do r <- funcTH objMap name - case r of - (Left e) -> putStrLn $ unlines e - (Right f) -> use f +withIO objMap name use = withIO' objMap name use [] +withIO' :: PluginHandle -> Name -> (a -> IO ()) -> [String] -> IO () +withIO' objMap name use args = + do (errs,ma) <- funcTH' objMap name args + when (not$ null errs)$ putStrLn $ unlines errs + maybe (return ()) use ma + + + nameToFileSym :: Name -> (FilePath, Symbol) nameToFileSym (Name occName (NameG _ _ mn)) = let dotToSlash '.' = '/' @@ -71,26 +117,34 @@ nameToFileSym n = error $ "nameToFileSym failed because Name was not the right kind. " ++ show n func :: PluginHandle -> FilePath -> Symbol -> IO (Either Errors a) -func ph@(PluginHandle (_inotify, objMap)) fp sym = - do om <- readMVar objMap +func ph fp sym = fmap reformatOutput$ func' ph fp sym [] + +func' :: PluginHandle -> FilePath -> Symbol -> [String] -> IO (Errors,Maybe a) +func' ph fp sym args = + do om <- readMVar$ phObjMap ph case Map.lookup fp om of Nothing -> do bracketOnError - (addSymbol ph fp sym) + (addSymbol ph fp sym args) (const$ deleteSymbol ph fp sym) - (const$ rebuild ph fp True) - func ph fp sym - (Just (_, _, Just errs, _)) -> return $ Left errs - (Just (_, _, Nothing, symbols)) -> + (const$ rebuild' ph fp True args) + func' ph fp sym args + (Just (_, _, merrs, symbols, _)) -> case Map.lookup sym symbols of Nothing -> - 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) + case merrs of + Nothing -> + do bracketOnError + (addSymbol ph fp sym args) + (const$ deleteSymbol ph fp sym) + (const$ rebuild' ph fp True args) + func' ph fp sym args + Just errs -> + return (errs,Nothing) + Just (_, [], mm) -> + return (maybe [] id merrs, fmap (fromSym . snd) mm) + Just (_, errs, mm) -> + return (errs,fmap (fromSym . snd) mm) replaceSuffix :: FilePath -> String -> FilePath replaceSuffix p sfx = case [ i | (i,'.') <- zip [0..] p ] of @@ -101,65 +155,72 @@ -> FilePath -- ^ source file to compile -> Bool -> IO () -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 +rebuild p fp forceReload = rebuild' p fp forceReload [] + +rebuild' :: PluginHandle -> FilePath -> Bool -> [String] -> IO () +rebuild' p fp forceReload args = + do rs <- readMVar (phObjMap p) >>= maybe newRecompilationState (\(_,_,_,_,rs)->return rs) . Map.lookup fp + bracket + (signalRecompilationStarted rs) + (\compile -> when compile$ signalRecompilationFinished rs (rebuild'' rs)) + (\compile -> when compile$ rebuild'' rs) + where + rebuild'' :: RecompilationState -> IO () + rebuild'' rs = do + putStrLn ("Rebuilding " ++ fp) + makeStatus <- makeAll fp (["-odir",".","-hidir",".","-o",replaceSuffix fp "o"]++args) case makeStatus of (MakeFailure errs) -> - do unload <- modifyMVar objMap $ \om -> + do modifyMVar_ (phObjMap p) $ \om -> case Map.lookup fp om of - Nothing -> do wds <- observeFiles p fp [] - return (Map.insert fp (wds, [], Just errs, Map.empty) om, []) - (Just (wds, deps, _, symbols)) -> - let symbols' = Map.map (\(loader,_) -> (loader, Left errs)) symbols -- propogate error to all symbols - in return (Map.insert fp (wds, deps, Just errs, symbols') om, unloadList symbols) - mapM_ unloadAll unload + Nothing -> do wds <- observeFiles p fp [] args rs + return$ Map.insert fp (wds, [], Just errs, Map.empty, rs) om + Just (wds, deps, _, symbols,_) -> + let symbols' = Map.map (\(loader,_,mm) -> (loader,errs,mm)) symbols -- propogate error to all symbols + in return$ Map.insert fp (wds, deps, Just errs, symbols',rs) om putStrLn $ unlines errs (MakeSuccess NotReq _objFilePath) | not forceReload -> do putStrLn "skipped reload." return () (MakeSuccess _makeCode objFilePath) -> - do om <- readMVar objMap + do om <- readMVar$ phObjMap p case Map.lookup fp om of Nothing -> return () - (Just (oldWds, _, _, symbols)) -> + Just (oldWds, _, _, symbols,_) -> do mapM_ unloadAll (unloadList symbols) - mapM_ removeWatchP oldWds + mapM_ removeWatch oldWds res <- mapM (load' objFilePath) (Map.assocs symbols) 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 - unloadList symbols = - nub $ mapMaybe (\(_, eSym) -> - case eSym of - (Left _) -> Nothing - (Right (m,_)) -> Just m) (Map.elems symbols) + wds <- observeFiles p fp imports args rs + modifyMVar_ (phObjMap p) $ return . Map.insert fp (wds, [], Nothing, Map.fromList res,rs) + + unloadList symbols = + nub$ mapMaybe (\(_, _, mm) -> fmap fst mm)$ Map.elems symbols - load' :: FilePath - -> (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) - -> IO (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) - load' obj (symbol, (reloader, _)) = + load' :: FilePath + -> (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Errors, Maybe (Module, Sym))) + -> IO (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Errors, Maybe (Module, Sym))) + load' obj (symbol, (reloader, _, _mm)) = do r <- reloader obj case r of (Left errs) -> putStrLn $ unlines errs (Right _) -> return () - return (symbol, (reloader, r)) + return (symbol, (reloader, either id (const []) r,either (const Nothing) Just 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 [WatchDescriptorP] -observeFiles p@(PluginHandle (inotify,_objMap)) fp imports = +observeFiles :: PluginHandle -> FilePath -> [FilePath] -> [String] -> RecompilationState -> IO [FSWatchDescriptor] +observeFiles p fp imports args rs = mapM (\depFp -> do putStrLn ("Adding watch for: " ++ depFp) - let handler e = putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) >> rebuild p fp False - addWatchP inotify depFp handler + let handler = putStrLn ("Got event for " ++ depFp) >> signalRecompilationNeeded rs (rebuild' p fp False args) + addWatch (phWatcher p) depFp handler ) (fp:imports) -addSymbol :: PluginHandle -> FilePath -> Symbol -> IO () -addSymbol p@(PluginHandle (_inotify, objMap)) sourceFP sym = +addSymbol :: PluginHandle -> FilePath -> Symbol -> [String] -> IO () +addSymbol p sourceFP sym args = do let reloader obj = do putStrLn $ "loading " ++ sym ++ " from " ++ sourceFP ldStatus <- load obj ["."] [] sym @@ -170,93 +231,83 @@ (LoadFailure errs) -> do putStrLn "Failed." return (Left errs) - symVal = (reloader, Left ["Not loaded yet.."]) - modifyMVar_ objMap $ \om -> + symVal = (reloader, [], Nothing) + modifyMVar_ (phObjMap p) $ \om -> case Map.lookup sourceFP om of - Nothing -> do wds <- observeFiles p sourceFP [] - return$ Map.insert sourceFP (wds, [], Nothing, Map.singleton sym symVal) om - (Just (wds, deps, errs, symbols)) -> + Nothing -> do rs <- newRecompilationState + wds <- observeFiles p sourceFP [] args rs + return$ Map.insert sourceFP (wds, [], Nothing, Map.singleton sym symVal,rs) om + (Just (wds, deps, errs, symbols,rs)) -> let symbols' = Map.insert sym symVal symbols - in return$ Map.insert sourceFP (wds, deps, errs, symbols') om + in return$ Map.insert sourceFP (wds, deps, errs, symbols',rs) om return () deleteSymbol :: PluginHandle -> FilePath -> Symbol -> IO () -deleteSymbol (PluginHandle (_inotify, objMap)) sourceFP sym = - modifyMVar_ objMap $ \om -> +deleteSymbol ph sourceFP sym = + modifyMVar_ (phObjMap ph) $ \om -> case Map.lookup sourceFP om of Nothing -> return om - (Just (wds, deps, errs, symbols)) -> + Just (wds, deps, errs, symbols,rs) -> let symbols' = Map.delete sym symbols - in return$ Map.insert sourceFP (wds, deps, errs, symbols') om + in return$ Map.insert sourceFP (wds, deps, errs, symbols',rs) om +-------------------------------- +-- Recompilation handling +-------------------------------- --- 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 - ) - ) - ) +-- | Indicates that recompilation is needed. If compilation is in progress +-- recompilation will be done afterwards, otherwise recompilation starts +-- in a few milliseconds after the call. +signalRecompilationNeeded :: RecompilationState -- ^ Internal state for synchronizing recompilation requests + -> IO () -- ^ Command which starts recompilation + -> IO () +signalRecompilationNeeded rs recomp = do + modifyMVar_ (rsRecompilationNeeded rs)$ const$ return True + mvarIf (rsRecompiling rs) (return ()) (testRecompilation rs recomp) -data WatchDescriptorP = WatchDescriptorP PersistentINotify FilePath -initPersistentINotify :: IO PersistentINotify -initPersistentINotify = do - iN <- initINotify - fmvar <- newMVar Map.empty - return$ PersistentINotify iN fmvar +-- | Indicates that recompilation is starting. The returned boolean indicates whether +-- there is any other attempt for recompilation in progress. +signalRecompilationStarted :: RecompilationState -> IO Bool +signalRecompilationStarted rs = do + modifyMVar (rsRecompiling rs)$ \b -> do + when (not b)$ modifyMVar_ (rsRecompilationNeeded rs)$ const$ return False + return (True,not b) --- 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 - +-- | Indicates that recompilation has stopped. +-- It test whether recompilation is needed, and if needed it starts it again. +signalRecompilationFinished :: RecompilationState -- ^ Internal state for synchronizing recompilation requests + -> IO () -- ^ Command which starts recompilation + -> IO () +signalRecompilationFinished rs recomp = do + modifyMVar_ (rsRecompiling rs)$ const$ return False + testRecompilation rs recomp -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) - - +-- | Fires the recompilation command after a small timeout if recompilation is needed +-- after the timeout expired. The timeout allows to delay recompilation if new requests +-- for recompilation arrive before the recompilation starts. +testRecompilation :: RecompilationState -> IO () -> IO () +testRecompilation rs recomp = setTimer (rsTimer rs) (400*1000)$ + mvarIf (rsRecompilationNeeded rs) recomp (return ()) + +mvarIf :: MVar Bool -> IO a -> IO a -> IO a +mvarIf mb th els = readMVar mb >>= \b -> if b then th else els + +-------------------------------- +-- Timer data type +-------------------------------- + +newtype Timer = Timer (MVar (Maybe ThreadId)) + +newTimer :: IO Timer +newTimer = fmap Timer$ newMVar Nothing + +-- Register an action to perform after a timeout. +-- Cancels previous timer setting. +setTimer :: Timer -> Int -> IO () -> IO () +setTimer (Timer mmtid) delay action = modifyMVar_ mmtid$ \mtid -> do + maybe (return ()) killThread mtid + fmap Just$ forkIO$ threadDelay delay >> modifyMVar_ mmtid (const (return Nothing)) >> action + diff --git a/Happstack/Server/Plugins/Dynamic.hs b/Happstack/Server/Plugins/Dynamic.hs --- a/Happstack/Server/Plugins/Dynamic.hs +++ b/Happstack/Server/Plugins/Dynamic.hs @@ -4,6 +4,8 @@ , initPlugins , withServerPart , withServerPart_ + , withServerPart' + , withServerPart_' ) where import Control.Monad.Trans (MonadIO(liftIO)) @@ -11,7 +13,7 @@ import Language.Haskell.TH.Syntax (Name) import Happstack.Plugins.Dynamic (initPlugins) import Happstack.Plugins.LiftName (liftName) -import Happstack.Plugins.Plugins (PluginHandle, funcTH) +import Happstack.Plugins.Plugins (PluginHandle, funcTH') import Happstack.Server (ServerMonad, FilterMonad, WebMonad, Response, internalServerError, escape, toResponse) -- | dynamically load the specified symbol pass it as an argument to @@ -27,6 +29,10 @@ withServerPart :: Name -> ExpQ withServerPart name = appE (appE [| withServerPart_ |] (liftName name)) (varE name) +withServerPart' :: Name -> ExpQ +withServerPart' name = appE (appE [| withServerPart_' |] (liftName name)) (varE name) + + -- | dynamically load the specified symbol pass it as an argument to -- the supplied server monad function. -- @@ -40,8 +46,20 @@ -> PluginHandle -- ^ Handle to the function reloader -> (a -> m b) -- ^ function which uses the loaded result -> m b -withServerPart_ name _fun ph use = - do r <- liftIO $ funcTH ph name - case r of - (Left e) -> escape $ internalServerError (toResponse (unlines e)) - (Right f) -> use f +withServerPart_ name fun ph use = withServerPart_' name fun ph [] use + +withServerPart_' :: (MonadIO m, ServerMonad m, FilterMonad Response m, WebMonad Response m) => + Name -- ^ name of the symbol to dynamically load + -> a -- ^ the symbol (must be the function refered to by the 'Name' argument) + -> PluginHandle -- ^ Handle to the function reloader + -> [String] -- ^ arguments for ghc + -> (a -> m b) -- ^ function which uses the loaded result + -> m b +withServerPart_' name _fun ph args use = + do (errs,ma) <- liftIO $ funcTH' ph name args + case errs of + [] -> case ma of + Nothing -> escape $ internalServerError$ toResponse "Module not loaded yet." + Just a -> use a + _ -> escape $ internalServerError$ toResponse$ unlines errs + diff --git a/Happstack/Server/Plugins/Static.hs b/Happstack/Server/Plugins/Static.hs --- a/Happstack/Server/Plugins/Static.hs +++ b/Happstack/Server/Plugins/Static.hs @@ -4,6 +4,8 @@ , initPlugins , withServerPart , withServerPart_ + , withServerPart' + , withServerPart_' ) where import Control.Monad.Trans (MonadIO(..)) @@ -21,6 +23,9 @@ withServerPart :: Name -> ExpQ withServerPart name = appE (appE [| withServerPart_ |] (liftName name)) (varE name) +withServerPart' :: Name -> ExpQ +withServerPart' name = appE (appE [| withServerPart_' |] (liftName name)) (varE name) + -- | a static version of 'Happstack.Server.Plugins.Dynamic.withServerPart_' -- -- This function has the same signature as its dynamic sibling, but it @@ -34,3 +39,7 @@ -- Use a CPP to select between the Dynamic and Static versions of this module. withServerPart_ :: (MonadIO m, ServerMonad m, FilterMonad Response m, WebMonad Response m) => Name -> a -> PluginHandle -> (a -> m b) -> m b withServerPart_ _name fun _objMap use = use fun + +withServerPart_' :: (MonadIO m, ServerMonad m, FilterMonad Response m, WebMonad Response m) => Name -> a -> PluginHandle -> [String] -> (a -> m b) -> m b +withServerPart_' _name fun _objMap _args use = use fun + 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.3 +Version: 6.1.0 Synopsis: The haskell application server stack + reload Description: This library provides support for automatically recompiling and reloading modules into a running server. License: BSD3 @@ -27,6 +27,7 @@ exposed-modules: Happstack.Plugins.Plugins Happstack.Plugins.Static Happstack.Plugins.Dynamic + Happstack.Plugins.FileSystemWatcher Happstack.Plugins.LiftName Happstack.Server.Plugins.Dynamic Happstack.Server.Plugins.Static