shiny/R/middleware-shiny.R

#' @include globals.R
NULL

reactLogHandler <- function(req) {
  if (!identical(req$PATH_INFO, '/reactlog'))
    return(NULL)

  if (!isTRUE(getOption('shiny.reactlog'))) {
    return(NULL)
  }

  sessionToken <- parseQueryString(req$QUERY_STRING)$s

  return(httpResponse(
    status=200,
    content=list(file=renderReactLog(sessionToken), owned=TRUE)
  ))
}

sessionHandler <- function(req) {
  path <- req$PATH_INFO
  if (is.null(path))
    return(NULL)

  matches <- regmatches(path, regexec('^(/session/([0-9a-f]+))(/.*)$', path))
  if (length(matches[[1]]) == 0)
    return(NULL)

  session <- matches[[1]][3]
  subpath <- matches[[1]][4]

  shinysession <- appsByToken$get(session)
  if (is.null(shinysession))
    return(NULL)

  subreq <- as.environment(as.list(req, all.names=TRUE))
  subreq$PATH_INFO <- subpath
  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, matches[[1]][2], sep='')

  withReactiveDomain(shinysession, {
    shinysession$handleRequest(subreq)
  })
}

apiHandler <- function(serverFuncSource) {
  function(req) {
    path <- req$PATH_INFO
    if (is.null(path))
      return(NULL)

    matches <- regmatches(path, regexec('^/api/(.*)$', path))
    if (length(matches[[1]]) == 0)
      return(NULL)

    apiName <- matches[[1]][2]

    sharedSecret <- getOption('shiny.sharedSecret')
    if (!is.null(sharedSecret)
      && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
      stop("Incorrect shared secret")
    }

    if (!is.null(getOption("shiny.observer.error", NULL))) {
      warning(
        call. = FALSE,
        "options(shiny.observer.error) is no longer supported; please unset it!"
      )
      stopApp()
    }

    # need to give a fake websocket to the session
    ws <- list(
      request = req,
      sendMessage = function(...) {
        #print(list(...))
      }
    )

    # Accept JSON query string and/or JSON body as input values
    inputVals <- c(
      parseQueryStringJSON(req$QUERY_STRING),
      parseJSONBody(req)
    )

    shinysession <- ShinySession$new(ws)
    on.exit({
      try({
        # Clean up the session. Very important, so that observers
        # and such don't hang around, and to let memory get gc'd.
        shinysession$wsClosed()
        appsByToken$remove(shinysession$token)
      })
    }, add = TRUE)
    appsByToken$set(shinysession$token, shinysession)
    shinysession$setShowcase(.globals$showcaseDefault)

    serverFunc <- withReactiveDomain(NULL, serverFuncSource())

    tryCatch({
      withReactiveDomain(shinysession, {
        shinysession$manageInputs(inputVals)
        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
        result <- NULL
        shinysession$enableApi(apiName, function(value) {
          result <<- try(withLogErrors(value), silent = TRUE)
        })
        flushReact()
        resultToResponse(result)
      })
    }, error = function(e) {
      return(httpResponse(
        status=500,
        content=htmlEscape(conditionMessage(e))
      ))
    })
  }
}

apiWsHandler <- function(serverFuncSource) {
  function(ws) {
    path <- ws$request$PATH_INFO
    if (is.null(path))
      return(NULL)

    matches <- regmatches(path, regexec('^/api/(.*)$', path))
    if (length(matches[[1]]) == 0)
      return(NULL)

    apiName <- matches[[1]][2]

    sharedSecret <- getOption('shiny.sharedSecret')
    if (!is.null(sharedSecret)
      && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
      ws$close()
      return(TRUE)
    }

    if (!is.null(getOption("shiny.observer.error", NULL))) {
      warning(
        call. = FALSE,
        "options(shiny.observer.error) is no longer supported; please unset it!"
      )
      stopApp()
    }

    inputVals <- parseQueryStringJSON(ws$request$QUERY_STRING)

    # Give a fake websocket to suppress messages from session
    shinysession <- ShinySession$new(list(
      request = ws$request,
      sendMessage = function(...) {
        #print(list(...))
      }
    ))
    appsByToken$set(shinysession$token, shinysession)
    shinysession$setShowcase(.globals$showcaseDefault)

    serverFunc <- withReactiveDomain(NULL, serverFuncSource())

    tryCatch({
      withReactiveDomain(shinysession, {
        shinysession$manageInputs(inputVals)
        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
        shinysession$enableApi(apiName, function(value) {
          resp <- resultToResponse(value)
          if (resp$status != 200L) {
            warning("Error: ", responseToContent(resp))
            ws$close()
          } else {
            content <- responseToContent(resp)
            if (grepl("^image/", resp$content_type)) {
              content <- paste0("data:", resp$content_type, ";base64,",
                httpuv::rawToBase64(content))
            }
            try(ws$send(content), silent=TRUE)
          }
        })
        flushReact()
      })
    }, error = function(e) {
      ws$close()
    })

    ws$onClose(function() {
      # Clean up the session. Very important, so that observers
      # and such don't hang around, and to let memory get gc'd.
      shinysession$wsClosed()
      appsByToken$remove(shinysession$token)
    })

    # TODO: What to do on ws$onMessage?
  }
}

parseJSONBody <- function(req) {
  if (identical(req[["REQUEST_METHOD"]], "POST")) {
    if (isTRUE(grepl(perl=TRUE, "^(text|application)/json(;\\s*charset\\s*=\\s*utf-8)?$", req[["HTTP_CONTENT_TYPE"]]))) {
      tmp <- file("", "w+b")
      on.exit(close(tmp))

      input_file <- req[["rook.input"]]
      while (TRUE) {
        chunk <- input_file$read(8192L)
        if (length(chunk) == 0)
          break
        writeBin(chunk, tmp)
      }

      return(jsonlite::fromJSON(tmp))
    }

    if (is.null(req[["HTTP_CONTENT_TYPE"]])) {
      if (!is.null(req[["rook.input"]]) && length(req[["rook.input"]]$read(1L)) > 0) {
        stop("Invalid POST request (body provided without content type)")
      }
      return()
    }

    stop("Invalid POST request (content type not supported)")
  }
}

resultToResponse <- function(result) {
  if (inherits(result, "httpResponse")) {
    return(result)
  } else if (inherits(result, "try-error")) {
    return(httpResponse(
      status=500,
      content_type="text/plain",
      content=conditionMessage(attr(result, "condition"))
    ))
  } else if (!is.null(attr(result, "content.type"))) {
    return(httpResponse(
      status=200L,
      content_type=attr(result, "content.type"),
      content=result
    ))
  } else {
    return(httpResponse(
      status=200L,
      content_type="application/json",
      content=toJSON(result, pretty=TRUE)
    ))
  }
}

responseToContent <- function(result) {
  ct <- result$content_type
  textMode <- grepl("^text/", ct) || ct == "application/json" ||
    grepl("^application/xml($|\\+)", ct)

  # TODO: Make sure text is UTF-8

  if ("file" %in% names(result$content)) {
    filename <- result$content$file
    if ("owned" %in% names(result$content) && result$content$owned) {
      on.exit(unlink(filename), add = TRUE)
    }
    if (textMode)
      return(paste(readLines(filename), collapse = "\n"))
    else
      return(readBin(filename, raw(), file.info(filename)$size))
  } else {
    if (textMode)
      return(paste(result$content, collapse = "\n"))
    else
      return(result$content)
  }
}