[codex] Fix RunDevServer SIGTERM orphaned GHCi

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)

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,16 +177,20 @@ 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'
      ":set prompt \"\"" -- Disable the prompt as this caused output such as '[38;5;208mIHP>[m Ser[v3e8r; 5s;t2a0r8tmedI' instead of 'Server started'
     , "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

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

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

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]))

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