fix: print "Listening on" only after the socket is bound (#4400)

NEWS.md

@@ -2,6 +2,8 @@
 
 * `{watcher}` is now a required dependency and is always used for autoreload file watching, so it no longer needs to be installed separately. The legacy polling-based file watcher has been removed. (#4403)
 
+* The `Listening on http://…` startup message is now printed only after the listening socket has been bound, so the announced URL is guaranteed to be accepting connections. Previously the message could be emitted just before the bind, leaving a window (widened under load) where the advertised port refused connections. (thanks @nbenn, #4400)
+
 # shiny 1.14.0
 
 ## New features

R/server.R

@@ -456,25 +456,31 @@ startHttpuvApp <- function(appObj, port, host, quiet) {
   )
 
   if (is.numeric(port) || is.integer(port)) {
+    # `startServer()` binds the socket synchronously, so only announce the URL
+    # after it returns. Otherwise the "Listening on" line (used as a readiness
+    # signal by shinytest2 and log watchers) can advertise a port that is not
+    # yet accepting connections (#4400).
+    server <- startServer(host, port, httpuvApp)
     if (!quiet) {
       hostString <- host
       if (httpuv::ipFamily(host) == 6L)
         hostString <- paste0("[", hostString, "]")
       message('\n', 'Listening on http://', hostString, ':', port)
     }
-    return(startServer(host, port, httpuvApp))
+    return(server)
   } else if (is.character(port)) {
-    if (!quiet) {
-      message('\n', 'Listening on domain socket ', port)
-    }
     mask <- attr(port, 'mask')
     if (is.null(mask)) {
       stop("`port` is not a valid domain socket (missing `mask` attribute). ",
            "Note that if you're using the default `host` + `port` ",
            "configuration (and not domain sockets), then `port` must ",
            "be numeric, not a string.")
     }
-    return(startPipeServer(port, mask, httpuvApp))
+    server <- startPipeServer(port, mask, httpuvApp)
+    if (!quiet) {
+      message('\n', 'Listening on domain socket ', port)
+    }
+    return(server)
   }
 }
 

tests/testthat/test-server.R

@@ -0,0 +1,57 @@
+test_that("startHttpuvApp() announces the URL only after the socket is bound (#4400)", {
+  # The "Listening on ..." message is used as a readiness signal (e.g. by
+  # shinytest2 and log watchers), so it must not be emitted until httpuv has
+  # actually bound the listening socket. Here we mock the (synchronous) bind and
+  # confirm the message is printed *after* it returns, never before.
+  withr::defer(handlerManager$clear())
+
+  app <- shinyApp(fluidPage(), function(input, output, session) {})
+
+  bound <- FALSE
+  bound_when_announced <- NULL
+
+  # Replace httpuv's startServer so no real socket is opened; record the bind.
+  local_mocked_bindings(
+    startServer = function(host, port, app, ...) {
+      bound <<- TRUE
+      structure(list(), class = "mock_server")
+    }
+  )
+
+  server <- withCallingHandlers(
+    startHttpuvApp(app, port = 3839L, host = "127.0.0.1", quiet = FALSE),
+    message = function(m) {
+      if (grepl("Listening on", conditionMessage(m), fixed = TRUE)) {
+        bound_when_announced <<- bound
+      }
+      invokeRestart("muffleMessage")
+    }
+  )
+
+  # The bind was attempted and its return value is passed through.
+  expect_true(bound)
+  expect_s3_class(server, "mock_server")
+
+  # The "Listening on" line was seen, and only after the bind had returned.
+  expect_true(isTRUE(bound_when_announced))
+})
+
+test_that("startHttpuvApp() with quiet = TRUE binds without announcing (#4400)", {
+  withr::defer(handlerManager$clear())
+
+  app <- shinyApp(fluidPage(), function(input, output, session) {})
+
+  bound <- FALSE
+  local_mocked_bindings(
+    startServer = function(host, port, app, ...) {
+      bound <<- TRUE
+      structure(list(), class = "mock_server")
+    }
+  )
+
+  expect_no_message(
+    server <- startHttpuvApp(app, port = 3839L, host = "127.0.0.1", quiet = TRUE)
+  )
+  expect_true(bound)
+  expect_s3_class(server, "mock_server")
+})