fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

(Principal) support for zero-downtime restart

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-13 20:39:01 +02:00
parent c17588912f
commit 92ec39143d
1 changed files with 15 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/Application.hs
View File

@ -78,10 +78,13 @@ import qualified System.Systemd.Daemon as Systemd
import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID) import System.Posix.Process (getProcessID)
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
import qualified System.Posix.Signals as Signals (Handler(..))
import Control.Monad.Trans.State (execStateT) import Control.Monad.Trans.State (execStateT)
import Network (socketPort) import Network (socketPort)
import qualified Network.Socket as Socket (close)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.) -- (HPack takes care to add new modules to our cabal file nowadays.)
@ -346,7 +349,9 @@ warpSettings foundation = defaultSettings
$(qLocation >>= liftLoc) $(qLocation >>= liftLoc)
"yesod" "yesod"
LevelError LevelError
(toLogStr $ "Exception from Warp: " ++ show e)) (toLogStr $ "Exception from Warp: " ++ show e)
)
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
@ -405,6 +410,15 @@ appMain = runResourceT $ do
$logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets
mainThreadId <- myThreadId
liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
$logInfoS "shutdown" [st|Received signal #{tshow siginfoSignal}|]
didStore <- runMaybeT . forM_ sockets $ MaybeT . liftIO . Systemd.storeFd
case didStore of
Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
Nothing -> forM_ sockets $ liftIO . Socket.close
liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
case sockets of case sockets of
[] -> $logErrorS "bind" "No sockets to listen on" [] -> $logErrorS "bind" "No sockets to listen on"