module Network.Wai.Application.Devel
(
AppHolder
, AppRunner
, WithAppRunner
, initAppHolder
, swapApp
, swapAppSimple
, toApp
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
( MVar, newEmptyMVar, newMVar
, takeMVar, putMVar, readMVar
)
import Network.Wai (Application, responseLBS)
import Network.HTTP.Types (status500)
import Data.ByteString.Lazy.Char8 ()
import Control.Monad.IO.Class (liftIO)
type AppHolder = MVar (Application, MVar ())
type AppRunner = Application -> IO ()
type WithAppRunner = AppRunner -> IO ()
initAppHolder :: IO AppHolder
initAppHolder = do
flag <- newEmptyMVar
newMVar (initApp, flag)
where
initApp _ = return
$ responseLBS status500 [("Content-Type", "text/plain")]
$ "No app has yet been loaded"
swapAppSimple :: Application -> AppHolder -> IO ()
swapAppSimple app =
swapApp war
where
war f = f app
swapApp :: WithAppRunner -> AppHolder -> IO ()
swapApp war ah = void $ forkIO $ war $ \app -> do
(_, oldFlag) <- takeMVar ah
putMVar oldFlag ()
flag <- newEmptyMVar
putMVar ah (app, flag)
takeMVar flag
where
void x = x >> return ()
toApp :: AppHolder -> Application
toApp ah req = do
(app, _) <- liftIO $ readMVar ah
app req