diff --git a/app/DevelMain.hs b/app/DevelMain.hs index b327943d8..0a7a89562 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -33,13 +33,15 @@ module DevelMain where import Prelude import Application (getApplicationRepl, shutdownApp) -import Control.Exception (finally) +import Control.Monad.Catch (finally) import Control.Monad ((>=>)) import Control.Concurrent import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp import GHC.Word +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class -- | Start or restart the server. -- newStore is from foreign-store. @@ -71,13 +73,14 @@ update = do -- | Start the server in a separate thread. start :: MVar () -- ^ Written to when the thread is killed. -> IO ThreadId - start done = do - (port, site, app) <- getApplicationRepl - forkIO (finally (runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (putMVar done () >> shutdownApp site)) + start done = runResourceT $ do + (port, site, app) <- getApplicationRepl + resourceForkIO $ do + finally (liftIO $ runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (liftIO $ putMVar done () >> shutdownApp site) -- | kill the server shutdown :: IO () diff --git a/src/Application.hs b/src/Application.hs index bdbed1b60..aba279998 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -13,10 +13,10 @@ module Application , develMain , makeFoundation , makeLogWare - -- -- * for DevelMain - -- , foundationStoreNum - -- , getApplicationRepl - -- , shutdownApp + -- * for DevelMain + , foundationStoreNum + , getApplicationRepl + , shutdownApp -- * for GHCI , handler , db @@ -251,28 +251,28 @@ appMain = runResourceT $ do liftIO $ runSettings (warpSettings foundation) app --- -------------------------------------------------------------- --- -- Functions for DevelMain.hs (a way to run the app from GHCi) --- -------------------------------------------------------------- --- foundationStoreNum :: Word32 --- foundationStoreNum = 2 +-------------------------------------------------------------- +-- Functions for DevelMain.hs (a way to run the app from GHCi) +-------------------------------------------------------------- +foundationStoreNum :: Word32 +foundationStoreNum = 2 --- getApplicationRepl :: IO (Int, UniWorX, Application) --- getApplicationRepl = do --- settings <- getAppDevSettings --- foundation <- makeFoundation settings --- wsettings <- getDevSettings $ warpSettings foundation --- app1 <- makeApplication foundation +getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) +getApplicationRepl = do + settings <- getAppDevSettings + foundation <- makeFoundation settings + wsettings <- liftIO . getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation --- let foundationStore = Store foundationStoreNum --- deleteStore foundationStore --- writeStore foundationStore foundation + let foundationStore = Store foundationStoreNum + liftIO $ deleteStore foundationStore + liftIO $ writeStore foundationStore foundation --- return (getPort wsettings, foundation, app1) + return (getPort wsettings, foundation, app1) --- shutdownApp :: UniWorX -> IO () --- shutdownApp UniWorX{..} = do --- atomically $ mapM_ closeTMChan appJobCtl +shutdownApp :: MonadIO m => UniWorX -> m () +shutdownApp UniWorX{..} = do + liftIO . atomically $ mapM_ closeTMChan appJobCtl --------------------------------------------- @@ -281,7 +281,7 @@ appMain = runResourceT $ do -- | Run a handler handler :: Handler a -> IO a -handler h = runResourceT $ liftIO getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a