git.iko.soy/typeable/wai
on master help sign in
Added Network.Wai.Application.Devel
e3809f4Michael Snoyman
Network/Wai/Application/Devel.hsnew file+58
compare with master
unifiedsplit
@@ -0,0 +1,58 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Application.Devel
3+ ( -- * Types
4+ AppHolder
5+ , AppRunner
6+ , WithAppRunner
7+ -- * Functions
8+ , initAppHolder
9+ , swapApp
10+ , swapAppSimple
11+ , toApp
12+ ) where
13+
14+import Control.Concurrent (forkIO)
15+import Control.Concurrent.MVar
16+ ( MVar, newEmptyMVar, newMVar
17+ , takeMVar, putMVar, readMVar
18+ )
19+import Network.Wai (Application, responseLBS, status500)
20+import Data.ByteString.Lazy.Char8 ()
21+import Control.Monad.IO.Class (liftIO)
22+
23+type AppHolder = MVar (Application, MVar ())
24+type AppRunner = Application -> IO ()
25+type WithAppRunner = AppRunner -> IO ()
26+
27+initAppHolder :: IO AppHolder
28+initAppHolder = do
29+ flag <- newEmptyMVar
30+ newMVar (initApp, flag)
31+ where
32+ initApp _ = return
33+ $ responseLBS status500 [("Content-Type", "text/plain")]
34+ $ "No app has yet been loaded"
35+
36+swapAppSimple :: Application -> AppHolder -> IO ()
37+swapAppSimple app =
38+ swapApp war
39+ where
40+ war f = f app
41+
42+swapApp :: WithAppRunner -> AppHolder -> IO ()
43+swapApp war ah = void $ forkIO $ war $ \app -> do
44+ (_, oldFlag) <- takeMVar ah
45+ -- allow the old app to cleanup
46+ putMVar oldFlag ()
47+ -- now place the new app into the AppHolder, waiting for a termination
48+ -- signal
49+ flag <- newEmptyMVar
50+ putMVar ah (app, flag)
51+ takeMVar flag -- this causes execution to hang until we are terminated
52+ where
53+ void x = x >> return ()
54+
55+toApp :: AppHolder -> Application
56+toApp ah req = do
57+ (app, _) <- liftIO $ readMVar ah
58+ app req