Fix build

This commit is contained in:
Gregor Kleen 2018-10-13 16:48:11 +02:00
parent 3297b56ebf
commit d00c6abd6b
2 changed files with 34 additions and 31 deletions

View File

@ -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 ()

View File

@ -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