Access an R shiny app running on a port from another port via httpuv

I have this very simple shiny app.

library(shiny)

ui <- fluidPage(
  tags$h1("Test App"),
  actionButton("btn", "Click me")
)

server <- function(input, output, session) {
  observeEvent(input$btn, {
    showNotification("Button clicked!")
  })
}

shinyApp(ui, server)

I am running it from my R session on a linux machine as follows:

shiny::runApp("minimal_app.R", port = 4040, host = "0.0.0.0", launch.browser = FALSE)

If I go to http://myserver:4040 in my browser, the app renders and works correctly (clicking the button displays a message saying the button was clicked).

I want to use the httpuv package so that I can go to http://myserver:8080 and access the shiny app running on port 4040.

This is the code I'm using to set that up.

library(httpuv)
library(httr)

s <- startServer("0.0.0.0", 8080,
                 list(
                   call = function(req) {
                     res <- GET(paste0("http://127.0.0.1:4040", req$PATH_INFO))
                     
                     content_type <- if (grepl("\\.css$", req$PATH_INFO)) {
                       "text/css"
                     } else if (grepl("\\.js$", req$PATH_INFO)) {
                       "application/javascript"
                     } else {
                       "text/html"
                     }
                     
                     list(
                       status = 200L,
                       headers = list(
                         'Content-Type' = content_type,
                         'X-Forwarded-Host' = req$HTTP_HOST,
                         'X-Forwarded-For' = req$REMOTE_ADDR
                       ),
                       body = content(res, type = "raw")
                     )
                   },
                   onWSOpen = function(ws) {
                     ws$onMessage(function(binary, message) {
                       ws$send(message)
                     })
                   }
                 )
)

When I run this code and then go http://myserver:8080 in the browser, I do see the app, and it looks correct, but it isn't functional (nothing happens when clicking the button).

Since the app loads correctly initially, I'm guessing the issue is with the websocket portion which I probably didn't do correctly. Is there a way to get this working as described?

Solution

Using the example found at this link provided by @margusl, I was able to get this working. https://rstudio.github.io/websocket/#websocket-proxy

library(httpuv)
library(httr)

s <- startServer("0.0.0.0", 8080,
                 list(
                   call = function(req) {
                     
                     res <- GET(paste0("http://127.0.0.1:4040", req$PATH_INFO))
                     
                     content_type <- if (grepl("\\.css$", req$PATH_INFO)) {
                       "text/css"
                     } else if (grepl("\\.js$", req$PATH_INFO)) {
                       "application/javascript"
                     } else {
                       "text/html"
                     }
                     
                     list(
                       status = 200L,
                       headers = list(
                         'Content-Type' = content_type,
                         'X-Forwarded-Host' = req$HTTP_HOST,
                         'X-Forwarded-For' = req$REMOTE_ADDR
                       ),
                       body = content(res, type = "raw")
                     )
                   },
                   onWSOpen = function(clientWS) {
                     serverWS <- websocket::WebSocket$new("ws://127.0.0.1:4040")
                     
                     msg_from_client_buffer <- list()
                     # Flush the queued messages from the client
                     flush_msg_from_client_buffer <- function() {
                       for (msg in msg_from_client_buffer) {
                         serverWS$send(msg)
                       }
                       msg_from_client_buffer <<- list()
                     }
                     
                     clientWS$onMessage(function(binary, msgFromClient) {
                       if (serverWS$readyState() == 0) {
                         msg_from_client_buffer[length(msg_from_client_buffer) + 1] <<- msgFromClient
                       } else {
                         serverWS$send(msgFromClient)
                       }
                     })
                     
                     serverWS$onOpen(function(event) {
                       serverWS$onMessage(function(msgFromServer) {
                         clientWS$send(msgFromServer$data)
                       })
                       flush_msg_from_client_buffer()
                     })
                   }
                 )
)