on master help sign in
implement reload-on-demand functionality

It is now possible to reload an app with any command starting with 'r'. Breaking API change: run now takes an additional parameter of type Maybe (MVar ()), which is the data structure used to propagate reload requests (if any).

commit2931fc6dbad546bf71183791fd7cc5e8393b78ba authorPatrick Palka <patrick@parcs.ath.cx> dateSat 14 May 2011, 07:39 (15 years ago) parentb38edd9
1 file changed+22−12
Network/Wai/Handler/DevelServer.hs+22−12
Network/Wai/Handler/DevelServer.hs+22−12
@@ -20,6 +20,9 @@ import Control.Exception (Exception, SomeException, toException, fromException)
2020import qualified Control.Exception as E
2121import Control.Concurrent (forkIO, threadDelay)
2222
23+import Data.Maybe
24+import Control.Concurrent.MVar
25+
2326import System.Directory (getModificationTime)
2427import qualified Network.Wai.Handler.Warp as Warp
2528import Network.Wai.Application.Devel
@@ -40,20 +43,26 @@ runNoWatch port modu func extras = do
4043runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
4144 -> IO ()
4245runQuit port modu func extras = do
43− _ <- forkIO $ run port modu func extras
44− go
46+ ev <- newEmptyMVar
47+ _ <- forkIO $ run port modu func extras (Just ev)
48+ go ev
4549 where
46− go = do
50+ go ev = do
4751 x <- getLine
4852 case x of
49− 'q':_ -> putStrLn "Quitting, goodbye!"
50− _ -> go
51−
52−run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
53+ 'q':_ -> do
54+ putStrLn "Quitting, goodbye!"
55+ 'r':_ -> do
56+ putStrLn "Forcing reinterpretation"
57+ _ <- tryPutMVar ev ()
58+ go ev
59+ _ -> go ev
60+
61+run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) -> Maybe (MVar ())
5362 -> IO ()
54−run port modu func extras = do
63+run port modu func extras mev = do
5564 ah <- initAppHolder
56− _ <- forkIO $ fillApp modu func extras ah
65+ _ <- forkIO $ fillApp modu func extras ah mev
5766 Warp.run port $ toApp ah
5867
5968{-
@@ -85,13 +94,14 @@ constSE :: x -> SomeException -> x
8594constSE = const
8695
8796fillApp :: String -> String
88− -> (FilePath -> IO [FilePath]) -> AppHolder -> IO ()
89−fillApp modu func dirs ah =
97+ -> (FilePath -> IO [FilePath]) -> AppHolder -> Maybe (MVar ()) -> IO ()
98+fillApp modu func dirs ah mev =
9099 go Nothing []
91100 where
92101 go prevError prevFiles = do
102+ forceReload <- maybe (return False) (fmap isJust . tryTakeMVar) mev
93103 toReload <-
94− if null prevFiles
104+ if forceReload || null prevFiles
95105 then return True
96106 else do
97107 times <- getTimes $ map fst prevFiles