diff --git a/src/Application.hs b/src/Application.hs index 3c0829c..c345b28 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -30,7 +30,6 @@ import Startlude import Control.Monad.Logger (liftLoc, runLoggingT) import Data.Aeson import Data.Default -import Data.IORef import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai @@ -76,7 +75,8 @@ makeFoundation appSettings = do -- subsite. appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger - appWebServerThreadId <- newIORef Nothing + appWebServerThreadId <- newEmptyMVar + appShouldRestartWeb <- newMVar False appCompatibilityMap <- decode . toS <$> readFile (appCompatibilityPath appSettings) >>= \case Nothing -> panic "invalid compatibility config" @@ -172,9 +172,10 @@ appMain = do -- allow environment variables to override useEnv - -- Generate the foundation from the settings - makeFoundation settings >>= startApp + makeFoundation settings >>= \f -> do + forkIO $ restartWeb f + startApp f startApp :: RegistryCtx -> IO () startApp foundation = do @@ -190,6 +191,7 @@ startApp foundation = do when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." renewSslCerts + liftIO $ restartWeb foundation liftIO $ sleep 86_400 startWeb foundation @@ -197,15 +199,28 @@ startApp foundation = do startWeb :: RegistryCtx -> IO () startWeb foundation = do app <- makeApplication foundation - let AppSettings{..} = appSettings foundation - putStrLn @Text $ "Launching Web Server on port " <> show appPort - action <- async $ runTLS - (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings foundation) - app + startWeb' app + where + startWeb' app = do + let AppSettings{..} = appSettings foundation + putStrLn @Text $ "Launching Web Server on port " <> show appPort + action <- async $ runTLS + (tlsSettings sslCertLocation sslKeyLocation) + (warpSettings foundation) + app - setWebProcessThreadId (asyncThreadId action) foundation - wait action + setWebProcessThreadId (asyncThreadId action) foundation + void $ waitCatch action + shouldRestart <- takeMVar (appShouldRestartWeb foundation) + when shouldRestart $ do + putMVar (appShouldRestartWeb foundation) False + putStrLn @Text "Restarting Web Server" + startWeb' app + +restartWeb :: RegistryCtx -> IO () +restartWeb foundation = do + void $ swapMVar (appShouldRestartWeb foundation) True + shutdownWeb foundation shutdownAll :: [ThreadId] -> IO () shutdownAll threadIds = do @@ -215,10 +230,8 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do - mThreadId <- readIORef appWebServerThreadId - for_ mThreadId $ \tid -> do - killThread tid - writeIORef appWebServerThreadId Nothing + threadId <- takeMVar appWebServerThreadId + killThread threadId -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) diff --git a/src/Foundation.hs b/src/Foundation.hs index ebb434c..4aa52e5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -10,7 +10,6 @@ import Startlude import Control.Monad.Logger ( LogSource ) import qualified Data.HashMap.Strict as HM -import Data.IORef import Database.Persist.Sql import Lib.Registry import Yesod.Core @@ -30,13 +29,14 @@ import Yesod.Persist.Core data RegistryCtx = RegistryCtx { appSettings :: AppSettings , appLogger :: Logger - , appWebServerThreadId :: IORef (Maybe ThreadId) + , appWebServerThreadId :: MVar ThreadId + , appShouldRestartWeb :: MVar Bool , appCompatibilityMap :: HM.HashMap AppVersion AppVersion , appConnPool :: ConnectionPool } setWebProcessThreadId :: ThreadId -> RegistryCtx -> IO () -setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid +setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: