(Principal) support for zero-downtime restart

src/Application.hs

@@ -78,10 +78,13 @@ import qualified System.Systemd.Daemon as Systemd
 import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
 import System.Environment (lookupEnv)
 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 Network (socketPort)
+import qualified Network.Socket as Socket (close)
 
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -346,7 +349,9 @@ warpSettings foundation = defaultSettings
             $(qLocation >>= liftLoc)
             "yesod"
             LevelError
-            (toLogStr $ "Exception from Warp: " ++ show e))
+            (toLogStr $ "Exception from Warp: " ++ show e)
+                     )
+                           
 
 getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
 getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
@@ -405,6 +410,15 @@ appMain = runResourceT $ do
 
       $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
       case sockets of
         []  -> $logErrorS "bind" "No sockets to listen on"