diff --git a/devenv-module.nix b/devenv-module.nix index be4bdc1fe..9cb374f7c 100644 --- a/devenv-module.nix +++ b/devenv-module.nix @@ -148,6 +148,31 @@ that is defined in flake-module.nix touch $out ''; }; + + run-devserver-sigterm = pkgs.stdenv.mkDerivation { + name = "run-devserver-sigterm"; + src = self; + sourceRoot = "source"; + nativeBuildInputs = [ + (pkgs.ghc.ghc.withPackages (p: with p; [ + ihp ihp-ide ihp-schema-compiler + ])) + pkgs.gnumake + pkgs.postgresql + pkgs.procps + ]; + buildPhase = '' + export IHP_LIB=${self.packages.${system}.ihp-env-var-backwards-compat} + export IHP_STATIC=${self.packages.${system}.ihp-static} + export PS_BIN=${pkgs.procps}/bin/ps + export RUN_DEVSERVER=${pkgs.ghc.ihp-ide}/bin/RunDevServer + + bash integration-test/run-devserver-sigterm-check.sh + ''; + installPhase = '' + touch $out + ''; + }; } # GHC 9.12 compatibility checks (build and test all IHP packages) diff --git a/ihp-ide/exe/IHP/IDE/DevServer.hs b/ihp-ide/exe/IHP/IDE/DevServer.hs index 5f52b43a6..036981fdd 100644 --- a/ihp-ide/exe/IHP/IDE/DevServer.hs +++ b/ihp-ide/exe/IHP/IDE/DevServer.hs @@ -5,6 +5,7 @@ import qualified System.Process as Process import IHP.HaskellSupport import qualified Data.ByteString.Char8 as ByteString import Control.Concurrent (threadDelay) +import qualified Control.Concurrent as Concurrent import IHP.IDE.Types import IHP.IDE.Postgres import IHP.IDE.StatusServer @@ -32,7 +33,9 @@ import qualified Control.Exception.Safe as Exception import qualified Data.ByteString.Builder as ByteString import qualified Network.Socket as Socket import qualified System.IO as IO +import qualified System.Exit as Exit import System.OsPath (OsPath, encodeUtf, decodeUtf) +import qualified System.Posix.Signals as Signals mainInParentDirectory :: IO () @@ -67,55 +70,79 @@ main = mainWithOptions False mainWithOptions :: Bool -> IO () mainWithOptions wrapWithDirenv = withUtf8 do - -- https://github.com/digitallyinduced/ihp/issues/2134 - -- devenv will redirect the standard handles to a pipe, causing block buffering by default - -- We need to override this so that `putStrLn` etc. works as expected - IO.hSetBuffering IO.stdout IO.LineBuffering - IO.hSetBuffering IO.stderr IO.LineBuffering - - databaseNeedsMigration <- newIORef False - portConfig <- findAvailablePortConfig - - -- Start the dev server in Debug mode by setting the env var DEBUG=1 - -- Like: $ DEBUG=1 devenv up - isDebugMode <- EnvVar.envOrDefault "DEBUG" False - - -- Create a persistent listening socket for the app port - -- This socket is shared between the status server and the app, - -- ensuring seamless transitions during app restarts (no connection refused errors) - appSocket <- createListeningSocket portConfig.appPort - - bracket (Log.newLogger def) (\logger -> logger.cleanup) \logger -> do - (ghciInChan, ghciOutChan) <- Queue.newChan - liveReloadClients <- newIORef mempty - lastSchemaCompilerError <- newIORef Nothing - let ?context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError, appSocket } - - -- Print IHP Version when in debug mode - when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion)) - - ghciIsLoadingVar <- newIORef False - reloadGhciVar :: MVar () <- newEmptyMVar - - withStatusServer ghciIsLoadingVar \startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients -> do - -- Compile Schema before loading the app - tryCompileSchema reloadGhciVar startStatusServer - - let toolServerApplication = ToolServerApplication - { appStandardOutput = statusServerStandardOutput - , appErrorOutput = statusServerErrorOutput - , appPort = portConfig.appPort - , databaseNeedsMigration - } - - - void $ runConcurrently $ (,,,,,) - <$> Concurrently (updateDatabaseIsOutdated databaseNeedsMigration) - <*> Concurrently (runToolServer toolServerApplication liveReloadClients) - <*> Concurrently (consumeGhciOutput statusServerStandardOutput statusServerErrorOutput statusServerClients) - <*> Concurrently Telemetry.reportTelemetry - <*> Concurrently (runFileWatcherWithDebounce (fileWatcherParams liveReloadClients databaseNeedsMigration reloadGhciVar startStatusServer)) - <*> Concurrently (runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar) + mainThreadId <- Concurrent.myThreadId + withSigTermHandler (Concurrent.throwTo mainThreadId Exit.ExitSuccess) do + -- https://github.com/digitallyinduced/ihp/issues/2134 + -- devenv will redirect the standard handles to a pipe, causing block buffering by default + -- We need to override this so that `putStrLn` etc. works as expected + IO.hSetBuffering IO.stdout IO.LineBuffering + IO.hSetBuffering IO.stderr IO.LineBuffering + + databaseNeedsMigration <- newIORef False + portConfig <- findAvailablePortConfig + + -- Start the dev server in Debug mode by setting the env var DEBUG=1 + -- Like: $ DEBUG=1 devenv up + isDebugMode <- EnvVar.envOrDefault "DEBUG" False + + -- Create a persistent listening socket for the app port + -- This socket is shared between the status server and the app, + -- ensuring seamless transitions during app restarts (no connection refused errors) + appSocket <- createListeningSocket portConfig.appPort + + bracket (Log.newLogger def) (\logger -> logger.cleanup) \logger -> do + (ghciInChan, ghciOutChan) <- Queue.newChan + liveReloadClients <- newIORef mempty + lastSchemaCompilerError <- newIORef Nothing + let ?context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError, appSocket } + + -- Print IHP Version when in debug mode + when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion)) + + ghciIsLoadingVar <- newIORef False + reloadGhciVar :: MVar () <- newEmptyMVar + + withStatusServer ghciIsLoadingVar \startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients -> do + -- Compile Schema before loading the app + tryCompileSchema reloadGhciVar startStatusServer + + let toolServerApplication = ToolServerApplication + { appStandardOutput = statusServerStandardOutput + , appErrorOutput = statusServerErrorOutput + , appPort = portConfig.appPort + , databaseNeedsMigration + } + + + void $ runConcurrently $ (,,,,,) + <$> Concurrently (updateDatabaseIsOutdated databaseNeedsMigration) + <*> Concurrently (runToolServer toolServerApplication liveReloadClients) + <*> Concurrently (consumeGhciOutput statusServerStandardOutput statusServerErrorOutput statusServerClients) + <*> Concurrently Telemetry.reportTelemetry + <*> Concurrently (runFileWatcherWithDebounce (fileWatcherParams liveReloadClients databaseNeedsMigration reloadGhciVar startStatusServer)) + <*> Concurrently (runAppGhci mainThreadId ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar) + +withSigTermHandler :: IO () -> IO a -> IO a +withSigTermHandler sigTermHandler callback = Exception.bracket + (Signals.installHandler Signals.sigTERM (Signals.Catch sigTermHandler) Nothing) + (\previousSigTermHandler -> void (Signals.installHandler Signals.sigTERM previousSigTermHandler Nothing)) + (\_ -> callback) + +stopProcessHandle :: Process.ProcessHandle -> IO () +stopProcessHandle processHandle = do + maybePid <- Process.getPid processHandle `Exception.catchAny` \_ -> pure Nothing + let signalGhciGroup signal = case maybePid of + Just pid -> do + -- GHCi runs in its own process group, so shutdown needs to target the + -- whole group rather than only the leader process. + Signals.signalProcessGroup signal pid `Exception.catchAny` \_ -> Signals.signalProcess signal pid `Exception.catchAny` \_ -> pure () + Nothing -> Process.terminateProcess processHandle `Exception.catchAny` \_ -> pure () + + signalGhciGroup Signals.sigTERM + exitedOnSigTerm <- isJust <$> timeout (1 * 1000000) (Process.waitForProcess processHandle `Exception.catchAny` \_ -> pure Exit.ExitSuccess) + unless exitedOnSigTerm do + signalGhciGroup Signals.sigKILL + void (timeout (1 * 1000000) (Process.waitForProcess processHandle `Exception.catchAny` \_ -> pure Exit.ExitSuccess)) fileWatcherParams liveReloadClients databaseNeedsMigration reloadGhciVar startStatusServer = FileWatcherParams @@ -140,8 +167,8 @@ ghciArguments = , "+RTS", "-A64m", "-n4m", "-H256m", "--nonmoving-gc", "-Iw60", "-N4" ] -withGHCI :: (?context :: Context) => (Handle -> Handle -> Handle -> Process.ProcessHandle -> IO a) -> IO a -withGHCI callback = do +withGHCI :: (?context :: Context) => Concurrent.ThreadId -> (Handle -> Handle -> Handle -> Process.ProcessHandle -> IO a) -> IO a +withGHCI mainThreadId callback = do baseParams <- procDirenvAware "ghci" ghciArguments let params = baseParams { Process.std_in = Process.CreatePipe @@ -150,7 +177,11 @@ withGHCI callback = do , Process.create_group = True } - Process.withCreateProcess params \(Just input) (Just output) (Just error) processHandle -> callback input output error processHandle + Process.withCreateProcess params \(Just input) (Just output) (Just error) processHandle -> do + let sigTermHandler = do + stopProcessHandle processHandle + Concurrent.throwTo mainThreadId Exit.ExitSuccess + withSigTermHandler sigTermHandler (callback input output error processHandle) initGHCICommands = [ -- The app is loaded by loading .ghci, which then loads applicationGhciConfig, which triggers a ':l Main.hs' @@ -158,8 +189,8 @@ initGHCICommands = , "import qualified ClassyPrelude" ] -runAppGhci :: (?context :: Context) => IORef Bool -> MVar () -> MVar (MVar ()) -> IORef [ByteString] -> IORef [ByteString] -> Clients -> MVar () -> IO () -runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar = do +runAppGhci :: (?context :: Context) => Concurrent.ThreadId -> IORef Bool -> MVar () -> MVar (MVar ()) -> IORef [ByteString] -> IORef [ByteString] -> Clients -> MVar () -> IO () +runAppGhci mainThreadId ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar = do -- The app is using the `PORT` env variable for its web server let appPort :: Int = fromIntegral ?context.portConfig.appPort Env.setEnv "PORT" (show appPort) @@ -217,7 +248,7 @@ runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStand processResult inputHandle outputHandle errorHandle processHandle result - withGHCI \inputHandle outputHandle errorHandle processHandle -> do + withGHCI mainThreadId \inputHandle outputHandle errorHandle processHandle -> do writeIORef ghciIsLoadingVar True withLoadedApp inputHandle outputHandle errorHandle receiveAppOutput \result -> do processResult inputHandle outputHandle errorHandle processHandle result diff --git a/integration-test/.ghci b/integration-test/.ghci new file mode 100644 index 000000000..443698c89 --- /dev/null +++ b/integration-test/.ghci @@ -0,0 +1,4 @@ +:set -XNoImplicitPrelude +:def loadFromIHP \file -> (System.Environment.getEnv "IHP_LIB") >>= (\ihpLib -> readFile (ihpLib <> "/" <> file)) +:loadFromIHP applicationGhciConfig +import IHP.Prelude diff --git a/integration-test/Main.hs b/integration-test/Main.hs new file mode 100644 index 000000000..1c28efbdf --- /dev/null +++ b/integration-test/Main.hs @@ -0,0 +1,16 @@ +module Main where + +import IHP.Prelude +import IHP.FrameworkConfig +import qualified IHP.Server +import IHP.Job.Types + +import Config +import Web.FrontController () +import Web.SlowLoad () + +instance Worker RootApplication where + workers _ = [] + +main :: IO () +main = IHP.Server.run config diff --git a/integration-test/Web/SlowLoad.hs b/integration-test/Web/SlowLoad.hs new file mode 100644 index 000000000..72988648a --- /dev/null +++ b/integration-test/Web/SlowLoad.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module Web.SlowLoad where + +import Control.Concurrent (threadDelay) +import Language.Haskell.TH.Syntax (Dec, runIO) +import Prelude (Int, pure, (*)) + +$(do + -- Keep GHCi in the initial :l Main.hs load long enough for the SIGTERM + -- regression check to hit the orphaning window deterministically. + runIO (threadDelay (10 * (1000000 :: Int))) + pure ([] :: [Dec])) diff --git a/integration-test/run-devserver-sigterm-check.sh b/integration-test/run-devserver-sigterm-check.sh new file mode 100644 index 000000000..617ac9e8c --- /dev/null +++ b/integration-test/run-devserver-sigterm-check.sh @@ -0,0 +1,99 @@ +#!/usr/bin/env bash +set -euo pipefail + +app_dir="$(pwd)/integration-test" +log_file="${TMPDIR:-/tmp}/run-devserver.log" +devserver_pid="" +ghci_pid="" +ps_bin="${PS_BIN:-ps}" + +cleanup() { + if [ -n "${ghci_pid:-}" ] && kill -0 "$ghci_pid" 2>/dev/null; then + kill -KILL "$ghci_pid" 2>/dev/null || true + fi + + if [ -n "${devserver_pid:-}" ] && kill -0 "$devserver_pid" 2>/dev/null; then + kill -KILL "$devserver_pid" 2>/dev/null || true + fi + + if [ -n "${PGDATA:-}" ]; then + pg_ctl -D "$PGDATA" stop >/dev/null 2>&1 || true + fi +} +trap cleanup EXIT + +find_ghci_child() { + "$ps_bin" -axo pid=,ppid=,command= | awk -v ppid="$devserver_pid" ' + $2 == ppid && $0 ~ /--interactive/ { print $1; exit } + ' +} + +export HOME="${TMPDIR:-/tmp}/home" +mkdir -p "$HOME" + +export PGDATA="${TMPDIR:-/tmp}/pgdata" +export PGHOST="${TMPDIR:-/tmp}/pghost" +mkdir -p "$PGHOST" +initdb -D "$PGDATA" --no-locale --encoding=UTF8 +echo "unix_socket_directories = '$PGHOST'" >> "$PGDATA/postgresql.conf" +echo "listen_addresses = ''" >> "$PGDATA/postgresql.conf" +pg_ctl -D "$PGDATA" -l "${TMPDIR:-/tmp}/pg.log" start +createdb -h "$PGHOST" app + +export DATABASE_URL="postgresql:///app?host=$PGHOST" +export IHP_BROWSER=true + +cd "$app_dir" +"$RUN_DEVSERVER" >"$log_file" 2>&1 & +devserver_pid="$!" + +for _ in $(seq 1 200); do + ghci_pid="$(find_ghci_child || true)" + if [ -n "$ghci_pid" ]; then + break + fi + sleep 0.1 +done + +if [ -z "$ghci_pid" ]; then + echo "RunDevServer never spawned the GHCi child" >&2 + cat "$log_file" >&2 + exit 1 +fi + +sleep 1 + +if grep -Eq 'modules (loaded|reloaded)\.|Server started' "$log_file"; then + echo "RunDevServer reached steady state before SIGTERM; fixture is too fast" >&2 + cat "$log_file" >&2 + exit 1 +fi + +kill -TERM "$devserver_pid" + +for _ in $(seq 1 100); do + if ! kill -0 "$devserver_pid" 2>/dev/null; then + break + fi + sleep 0.1 +done + +if kill -0 "$devserver_pid" 2>/dev/null; then + echo "RunDevServer did not exit after SIGTERM" >&2 + cat "$log_file" >&2 + exit 1 +fi + +for _ in $(seq 1 20); do + if ! kill -0 "$ghci_pid" 2>/dev/null; then + break + fi + sleep 0.1 +done + +if kill -0 "$ghci_pid" 2>/dev/null; then + echo "Orphaned GHCi process survived RunDevServer SIGTERM" >&2 + "$ps_bin" -o pid=,ppid=,command= -p "$ghci_pid" >&2 || true + cat "$log_file" >&2 + exit 1 +fi