feat(mcp): update a running Shiny MCP App in place via update_<appId>_app (#4415)

NEWS.md

@@ -1,5 +1,11 @@
 # shiny (development version)
 
+* Shiny MCP Apps configured with `mcpConfigure(arguments = ...)` now
+  auto-register a companion `update_<appId>_app` tool. A model can call it to
+  update an already-open app instance in place (via `mcpUpdates()`) instead of
+  re-opening the app, targeting a specific instance by the `session` id the app
+  announces on connect. (#4415)
+
 * Experimental support for serving a Shiny app as an MCP App (the Model
   Context Protocol Apps extension, SEP-1865). Calling `mcpConfigure()`
   before the app starts mounts an MCP endpoint at `/mcp` on the app's

R/mcp-config.R

@@ -132,6 +132,14 @@ mcpToolName <- function() {
   if (is.null(id)) "open_shiny_app" else paste0("open_", id, "_app")
 }
 
+# update_shiny_app, or update_<appId>_app when an appId is configured. The
+# companion to mcpToolName(): the model calls this to change a running
+# instance in place instead of re-opening the app.
+mcpUpdateToolName <- function() {
+  id <- .globals$mcp$appId
+  if (is.null(id)) "update_shiny_app" else paste0("update_", id, "_app")
+}
+
 # Convert the configured `arguments` (named list of ellmer types) into the
 # JSON Schema published as the tool's inputSchema. Mirrors
 # mcpToolInputSchema() (R/mcp-server.R) so the two conversions stay aligned.

R/mcp-server.R

@@ -207,6 +207,34 @@ mcpToolInfo <- function() {
   )
 }
 
+# inputSchema for update_<appId>_app: the declared arguments allow-list plus a
+# required `session` string identifying the running instance to update.
+mcpUpdateToolInfo <- function() {
+  schema <- mcpArgumentsSchema(.globals$mcp$arguments)
+  schema$properties$session <- list(
+    type = "string",
+    description = paste(
+      "Id of the running app instance to update, as reported by the app when",
+      "it opened. Required."
+    )
+  )
+  schema$required <- as.list(unique(c(unlist(schema$required), "session")))
+  list(
+    name = mcpUpdateToolName(),
+    description = paste(
+      "Change parameters of the already-open app in place. Do NOT re-open the",
+      "app; use this to update the running instance identified by `session`."
+    ),
+    inputSchema = schema
+  )
+}
+
+# TRUE when a companion update_* tool should be published (author declared
+# arguments the model may push into a running session).
+mcpHasUpdateTool <- function() {
+  length(.globals$mcp$arguments) > 0
+}
+
 mcpCorsHeaders <- function() {
   list(
     "Access-Control-Allow-Origin" = "*",
@@ -334,6 +362,16 @@ mcpInitializeResult <- function(body) {
 
 mcpToolsList <- function() {
   info <- mcpToolInfo()
+  update_entry <- if (mcpHasUpdateTool()) {
+    upd <- mcpUpdateToolInfo()
+    list(list(
+      name = upd$name,
+      description = upd$description,
+      inputSchema = upd$inputSchema
+    ))
+  } else {
+    list()
+  }
   # unname: a partially named list would serialize as a JSON object rather
   # than the array that tools/list requires.
   unname(c(
@@ -343,6 +381,7 @@ mcpToolsList <- function() {
       inputSchema = info$inputSchema,
       `_meta` = list(ui = list(resourceUri = mcpResourceUri()))
     )),
+    update_entry,
     mcpTunnelToolsList(),
     lapply(mcpAuthorTools(), function(tool) {
       dropNulls(list(
@@ -358,6 +397,7 @@ mcpToolsList <- function() {
 mcpReservedToolNames <- function() {
   c(
     mcpToolInfo()$name,
+    if (mcpHasUpdateTool()) mcpUpdateToolName(),
     vapply(mcpTunnelToolsList(), function(t) t$name, character(1))
   )
 }
@@ -431,6 +471,40 @@ mcpAuthorToolCall <- function(tool, params, id) {
   )
 }
 
+# Handle a model call to update_<appId>_app: push the (allow-list-filtered)
+# arguments into the running session named by `session`, inside that session's
+# reactive domain so its mcpUpdates() observer re-fires.
+mcpUpdateAppCall <- function(params, id) {
+  args <- params$arguments %||% list()
+  token <- args$session
+  if (!is.character(token) || length(token) != 1 || !nzchar(token)) {
+    return(mcpToolErrorResult(
+      id,
+      "update requires a `session` id identifying the running app instance."
+    ))
+  }
+  session <- appsByToken$get(token)
+  if (is.null(session) || !isMcpSession(session)) {
+    return(mcpToolErrorResult(id, sprintf(
+      paste(
+        "No running app session with id '%s'. Open the app first, or use the",
+        "id the app reported for the instance you want to change."
+      ),
+      token
+    )))
+  }
+  pushed <- mcpFilterArguments(args[setdiff(names(args), "session")])
+  withReactiveDomain(session, {
+    rv <- mcpServerUpdatesFor(session)
+    rv(utils::modifyList(isolate(rv()) %||% list(), pushed))
+  })
+  session$requestFlush()
+  mcpResult(id, list(content = list(list(
+    type = "text",
+    text = "Updated the running app in place."
+  ))))
+}
+
 mcpToolCall <- function(body, uiHandler, wsHandler) {
   name <- body$params$name %||% ""
   info <- mcpToolInfo()
@@ -442,6 +516,9 @@ mcpToolCall <- function(body, uiHandler, wsHandler) {
       ))
     )))
   }
+  if (mcpHasUpdateTool() && identical(name, mcpUpdateToolName())) {
+    return(mcpUpdateAppCall(body$params, body$id))
+  }
   localName <- mcpTunnelLocalName(name)
   if (startsWith(localName, "_shiny_")) {
     return(mcpTunnelToolCall(

R/mcp-session.R

@@ -15,12 +15,18 @@
 #'   `mcpConfigure(arguments = list(...))`. Apply them from a single
 #'   `observe()` with the usual `updateXxxInput()` functions. Hosts render a
 #'   fresh instance for each tool call, so the same observer handles both the
-#'   initial open and any later re-open.
+#'   initial open and any later re-open. When `arguments` are declared,
+#'   an `update_<appId>_app` tool is auto-registered; the model can call it
+#'   to push new argument values to a running instance (server-side), which
+#'   also arrive through this same `mcpUpdates()` channel.
 #' * `mcpHostContext()` returns the host's context (theme, locale, display
 #'   mode, ...) as a named list (reactive read).
 #' * `mcpUpdateModelContext()` updates the model's context for future
 #'   conversation turns. Each call overwrites the previous update; the host
-#'   typically delivers it with the user's next message.
+#'   typically delivers it with the user's next message. On connect, the
+#'   framework automatically announces the app instance's `session` id to
+#'   the model (via `mcpAnnounceSession()`), so the model can target the
+#'   running instance with `update_<appId>_app(session = "<id>", ...)`.
 #' * `mcpSendMessage()` sends a user-role message to the host's chat
 #'   interface, which may trigger a model response.
 #'
@@ -92,6 +98,27 @@
 #' @name mcp-session
 NULL
 
+# Server-pushed MCP updates, keyed by session token. Shared between
+# mcpUpdates() (a reactive read) and the update_<appId>_app tool handler (a
+# server-side write): both fetch the *same* reactiveVal for a given session so
+# a push invalidates the app's mcpUpdates() observer. Created lazily; removed
+# when the session ends.
+mcpSessionUpdates <- NULL
+on_load({
+  mcpSessionUpdates <- Map$new()
+})
+
+mcpServerUpdatesFor <- function(session) {
+  token <- session$token
+  rv <- mcpSessionUpdates$get(token)
+  if (is.null(rv)) {
+    rv <- reactiveVal(NULL, label = "mcpServerUpdates")
+    mcpSessionUpdates$set(token, rv)
+    session$onSessionEnded(function() mcpSessionUpdates$remove(token))
+  }
+  rv
+}
+
 #' @rdname mcp-session
 #' @export
 isMcpSession <- function(session = getDefaultReactiveDomain()) {
@@ -121,7 +148,16 @@ mcpUpdates <- function(session = getDefaultReactiveDomain()) {
   if (is.null(session)) {
     stop("mcpUpdates() must be called from within a Shiny session")
   }
-  mcpFilterArguments(mcpParseClientData(session$clientData$mcp_tool_input))
+  clientArgs <- mcpParseClientData(session$clientData$mcp_tool_input)
+  # Server-side pushes from update_<appId>_app overlay the client-delivered
+  # init args, per key (latest wins). Reading the reactiveVal registers the
+  # dependency so a push re-fires this observer.
+  serverArgs <- mcpServerUpdatesFor(session)()
+  if (is.null(clientArgs) && is.null(serverArgs)) {
+    return(NULL)
+  }
+  merged <- utils::modifyList(clientArgs %||% list(), serverArgs %||% list())
+  mcpFilterArguments(merged)
 }
 
 #' @rdname mcp-session
@@ -156,11 +192,15 @@ mcpUpdateModelContext <- function(
   if (!isMcpSession(session)) {
     return(invisible(FALSE))
   }
+  structured <- dropNulls(list(
+    session = session$token,
+    data = data
+  ))
   params <- dropNulls(list(
     content = if (!is.null(text)) {
       list(list(type = "text", text = text))
     },
-    structuredContent = data
+    structuredContent = structured
   ))
   session$sendCustomMessage("shiny.mcp.updateModelContext", params)
   invisible(TRUE)
@@ -185,6 +225,40 @@ mcpSendMessage <- function(
   invisible(TRUE)
 }
 
+# Tell the model, once per MCP session, the id it must pass to
+# update_<appId>_app to change THIS running instance in place. Sent after the
+# first flush (the client bridge is initialized by then) via the same
+# updateModelContext bridge channel. The token instruction is text so the
+# model knows to echo the id; the structured {session, state} carries it
+# machine-readably. Only meaningful when an update_* tool exists (arguments
+# declared) and this is an MCP session.
+#
+# NOTE: this builds its own shiny.mcp.updateModelContext payload rather than
+# calling mcpUpdateModelContext() because the announcement needs the reserved
+# `state` key in structuredContent (not the author-facing `data` key). If the
+# envelope shape of mcpUpdateModelContext() changes, this must be updated
+# independently.
+mcpAnnounceSession <- function(session) {
+  session$onFlushed(
+    function() {
+      token <- session$token
+      instruction <- sprintf(
+        paste(
+          "This app instance's id is \"%s\". To change THIS instance in",
+          "place, call %s with session = \"%s\". Do not re-open the app to",
+          "change it."
+        ),
+        token, mcpUpdateToolName(), token
+      )
+      session$sendCustomMessage("shiny.mcp.updateModelContext", list(
+        content = list(list(type = "text", text = instruction)),
+        structuredContent = list(session = token, state = "connected")
+      ))
+    },
+    once = TRUE
+  )
+}
+
 #' @param mode The display mode to request: `"inline"`, `"fullscreen"`, or
 #'   `"pip"`. The host may decline; observe `mcpHostContext()$displayMode`
 #'   for the mode actually in effect. Declare the modes the app supports

R/server.R

@@ -174,6 +174,9 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
 
     shinysession <- ShinySession$new(ws)
     appsByToken$set(shinysession$token, shinysession)
+    if (mcpEnabled() && mcpHasUpdateTool() && isMcpSession(shinysession)) {
+      mcpAnnounceSession(shinysession)
+    }
     shinysession$setShowcase(.globals$showcaseDefault)
 
     messageHandler <- function(binary, msg) {

mcp/demo-app/app.R

@@ -59,9 +59,8 @@ shinyApp(
   server = function(input, output, session) {
     initNote <- reactiveVal("")
 
-    # Apply the model's arguments in one observer. The host renders a fresh
-    # instance for every tool call, so this handles both the initial open and
-    # any later re-open with new arguments.
+    # Apply the model's arguments in one observer. Handles both the initial
+    # open and in-place updates via update_demo_app(session = ..., ...).
     observe({
       args <- mcpUpdates()
       if (!is.null(args$n)) {

mcp/demo-app2/app.R

@@ -38,6 +38,7 @@ shinyApp(
     )
   ),
   server = function(input, output, session) {
+    # Handles both initial open and in-place updates via update_cars_app().
     observe({
       args <- mcpUpdates()
       if (!is.null(args$xvar) && args$xvar %in% vars) {

mcp/demo-app3/app.R

@@ -47,7 +47,9 @@ shinyApp(
     running <- reactiveVal(TRUE)
     heading <- reactiveVal("Live clock")
 
-    # Restore any arguments the model passed when opening the app.
+    # Restore args on open AND apply later in-place updates: the model can call
+    # update_clock_app(session = ..., label = ...) to change this running
+    # instance without re-opening it. Both arrive through mcpUpdates().
     observe({
       args <- mcpUpdates()
       if (!is.null(args$label) && nzchar(args$label)) {