happstack-plugins 6.0.3 → 6.1.0
raw patch · 6 files changed
+329/−162 lines, 6 files
Files
- Happstack/Plugins/Dynamic.hs +3/−10
- Happstack/Plugins/FileSystemWatcher.hs +95/−0
- Happstack/Plugins/Plugins.hs +196/−145
- Happstack/Server/Plugins/Dynamic.hs +24/−6
- Happstack/Server/Plugins/Static.hs +9/−0
- happstack-plugins.cabal +2/−1
Happstack/Plugins/Dynamic.hs view
@@ -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))+
+ Happstack/Plugins/FileSystemWatcher.hs view
@@ -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)+ +
Happstack/Plugins/Plugins.hs view
@@ -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+
Happstack/Server/Plugins/Dynamic.hs view
@@ -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+
Happstack/Server/Plugins/Static.hs view
@@ -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+
happstack-plugins.cabal view
@@ -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