Test app for rstudio/shiny#3666

app.R

# Test app for https://github.com/rstudio/shiny/pull/3666

# pkgload::load_all()

library(promises)
library(httpuv)
library(htmltools)
library(shiny)
library(later)
options(shiny.minified = FALSE)

# ==============================================================================
# Monkey-patch shiny::uiHttpHandler so that UI functions can return a promise.
# ==============================================================================
# This was taken from Shiny 1.7.3. Note that if the source changes in the
# future, we'll need to update this.

shiny_uiHttpHandler <- function(ui, uiPattern = "^/$") {

  force(ui)

  allowed_methods <- "GET"
  if (is.function(ui)) {
    allowed_methods <- attr(ui, "http_methods_supported", exact = TRUE) %||% allowed_methods
  }

  function(req) {
    if (!isTRUE(req$REQUEST_METHOD %in% allowed_methods))
      return(NULL)

    if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
      return(NULL)

    showcaseMode <- .globals$showcaseDefault
    if (.globals$showcaseOverride) {
      mode <- showcaseModeOfReq(req)
      if (!is.null(mode))
        showcaseMode <- mode
    }

    testMode <- getShinyOption("testmode", default = FALSE)

    # Create a restore context using query string
    bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
    if (bookmarkStore == "disable") {
      # If bookmarking is disabled, use empty context
      restoreContext <- RestoreContext$new()
    } else {
      restoreContext <- RestoreContext$new(req$QUERY_STRING)
    }

    withRestoreContext(restoreContext, {
      uiValue <- NULL

      if (is.function(ui)) {
        if (length(formals(ui)) > 0) {
          # No corresponding ..stacktraceoff.., this is pure user code
          uiValue <- ..stacktraceon..(ui(req))
        } else {
          # No corresponding ..stacktraceoff.., this is pure user code
          uiValue <- ..stacktraceon..(ui())
        }
      } else {
        if (getCurrentRestoreContext()$active) {
          warning("Trying to restore saved app state, but UI code must be a function for this to work! See ?enableBookmarking")
        }
        uiValue <- ui
      }
    })
    if (is.null(uiValue))
      return(NULL)

    if (is.promise(uiValue)) {
      return(uiValue)
    } else if (inherits(uiValue, "httpResponse")) {
      return(uiValue)
    } else {
      html <- renderPage(uiValue, showcaseMode, testMode)
      return(httpResponse(200, content = html))
    }
  }
}
environment(shiny_uiHttpHandler) <- asNamespace("shiny")
assignInNamespace("uiHttpHandler", shiny_uiHttpHandler, "shiny")


# ==============================================================================
# App
# ==============================================================================
ui <- function(req) {
  path <- req$PATH_INFO
  message("Request received for ", path)

  # Request is for main HTML page
  if (path == "/") {
    return(
      fluidPage(
        fluidRow(
          h2("Dynamic <script> loading test"),

          radioButtons("type", "Test type",
            c("None" = "none", "Delay 2s" = "delay", "Error" = "error")
          ),
          uiOutput("content"),
          pre(id = "dyn-content"),
          markdown(
            "
This app tests the loading order of \\<script> tags in HTML dependencies.
The starting state is **none**, which means to not load any script tags.

*****

When **delay** is selected, it will try to load the following scripts:
* a-1.js
* a-2-delay.js: This will load with 2 second delay.
* a-3-404.js: The server will respond with a 404.
* a-4.js
* b-1.js

Even though the client should download a-4.js _before_ a-2-delay.js, they should
still be executed in the order in which they're inserted in the DOM. These will
be logged to the code block, and should be in this order:
* a-1.js
* a-2-delay.js
* a-4.js
* b-1.js

(a-3-404.js won't execute because the server replies with a 404.)

*****

When **error** is selected, it will try to load the following scripts:
* a-1.js
* a-2-error.js: This script will throw an error.
* a-3-404.js: The server will respond with a 404.
* a-4.js
* b-1.js

The scripts should log the following to the code block:
* a-1.js
* a-4.js
* b-1.js

a-2-error.js will execute, but it will throw an error before it logs to the code
block. a-3-404.js won't execute because the server response is a 404. Note that
despite the JS error and the missing file, it should continue running subsequent
scripts: a-4.js and b-1.js.
           "
          ),
          div("Shiny version ", as.character(packageVersion("shiny"))),
        )
      )
    )
  }

  # Request is for one of our custom JS files
  if (grepl("^/test/.*\\.js", path)) {

    # If the requested name contains "404", then send a 404 response.
    if (grepl("^/test/.*404", path)) {
      return(
        structure(
          list(status = 404, content = "Not found"),
          class = "httpResponse"
        )
      )
    }

    # Fill in the content for a response containing a JS file.
    body <- ""

    if (grepl("error", path)) {
      body <- paste0(body, "throw 'An error happened in ", path, "';\n")
    }
    body <- paste0(
      body,
      sprintf(
        "
        (() => {
          const msg = 'Ran %s\\n';
          console.log(msg);
          const d = document.getElementById('dyn-content');
          if (d) {
            d.innerHTML += msg;
          }
        })();
        ",
        path
      )
    )

    res <- structure(
      list(
        status = 200L,
        headers = list('Content-Type' = 'text/javascript'),
        content = body
      ),
      class = "httpResponse"
    )


    if (grepl("delay", path)) {
      return(
        promise(function(resolve, reject) {
          message("Promise for ", path)

          message("Delaying for ", path)
          later::later(
            function() {
              message("Resolving", path)
              resolve(res)
            },
            2
          )
        })
      )
    } else {
      return(res)
    }
  }

  # Request is for something else (normal static assets). Fall through.
  NULL
}


app <- shinyApp(
  ui = ui,
  server = function(input, output) {
    output$content <- renderUI({
      if (input$type == "none") {
        return(div())
      } else if (input$type == "delay") {
        type <- "delay"
      } else if (input$type == "error") {
        type <- "error"
      }

      div(
        htmlDependency(
          paste0("test-", type, "-a"),
          "1.0",
          src = list(href = "/test"),
          script = c(
            "a-1.js",
            paste0("a-2-", type, ".js"),
            "a-3-404.js",
            "a-4.js"
          )
        ),
        htmlDependency(
          paste0("test-", type, "-b"),
          "1.0",
          src = list(href = "/test"),
          script = "b-1.js"
        )
      )
    })
  },
  uiPattern = "^/|(/test).*"
)

runApp(app, launch.browser=F, port=8007)