A proposal for a Chrome Remote Interface with R

crrry.R

# A proposal for a Chrome Remote Interface with R
# Copyright: Romain Lesur
# Year: 2018
# License: MIT

# Browser and websocket connection helpers --------------------------------
# From milesmcbain/chradle (MIT License)
debugger_200_ok <- function(port, retry_delay = 0.2, max_attempts = 15, attempt = 1) {
  if (max_attempts <= attempt) {
    stop(paste0("Reached max attempts (", max_attempts, 
                ") without HTTP 200 response from debugger on http://localhost:", port
    ))
  }
  
  url <- paste0("http://localhost:", port)
  check_url <- purrr::safely(httr::GET, otherwise = NA)
  response <- check_url(url, httr::use_proxy(""))
  
  if (is.na(response$result) || response$result$status_code != 200) {
    Sys.sleep(retry_delay)
    Recall(port, retry_delay, max_attempts, attempt = attempt + 1)
  } else {
    TRUE
  }
}

# From milesmcbain/chradle
browser_init <- function(debug_port = 9222, bin = "google-chrome", extra_args = NULL, headless = TRUE) {
  if (.Platform$OS.type == "windows") 
    extra_args <- c(extra_args, "--disable-gpu", if (headless) "--no-sandbox")
  
  if (nzchar(Sys.getenv("http_proxy"))) 
    extra_args <- c(
      extra_args, 
      paste("--proxy-server", Sys.getenv("http_proxy"), sep = "="),
      "--proxy-bypass-list=localhost"
    )
  
  debug_process <- processx::process$new(bin,
                                         c(if (headless) "--headless" else "--new-window",
                                           "--user-data-dir=remote-profile", extra_args,
                                           paste0("--remote-debugging-port=", debug_port)))
  debugger_200_ok(debug_port)
  cat("Chrome succesfully launched", if (headless) "in headless mode", "\n")
  debug_process
}

# From milesmcbain/chradle
chr_clean <- function(){
  processx::process$new("rm", c("-rf", "remote-profile"))
  invisible()
}

# Adapted from milesmcbain/chradle
ws_addr <- function(debug_port = 9222) {
  open_debuggers <-
    jsonlite::read_json(sprintf("http://localhost:%s/json", debug_port), simplifyVector = TRUE)
  open_debuggers$webSocketDebuggerUrl[open_debuggers$type == "page"]
}

# New connection helper
chrome_init <- function(bin = "google-chrome", debug_port = 9222, extra_args = NULL, async = FALSE) {
  debug_process <- browser_init(debug_port, bin, c(extra_args))
  headless_address <- ws_addr(debug_port)
  ws <- websocket::WebSocket$new(headless_address, autoConnect = FALSE)
  ws$onOpen(function(event) {
    cat("R succesfully connected to headless Chrome through DevTools Protocol\n")
  })
  ws$onMessage(function(event) {
    data <- jsonlite::fromJSON(event$data)
    cat("Client got msg: ", event$data, "\n")
  })
  ws$onClose(function(event) {
    cat("Client disconnected with code ", event$code,
        " and reason ", event$reason, "\n", sep = "")
    if (debug_process$kill()) cat("Chrome closed.\n") else warning("Cannot close Chrome: already closed.", call. = FALSE)
  })
  ws$onError(function(event) {
    cat("Client failed to connect: ", event$message, "\n")
    if (debug_process$kill()) cat("Chrome closed.\n") else warning("Cannot close Chrome: already closed.", call. = FALSE)
  })
  ws$connect()
  protocol <- jsonlite::read_json(sprintf("http://localhost:%s/json/protocol", debug_port))
  list(ws = ws, protocol = protocol, debug_process = debug_process, result = NULL)  
}

close_chrome <- function(cnx) {
  cnx$ws$close()
  chr_clean()
}

# Helpers for the DevTools protocol ---------------------------------------
get_domain <- function(method) {
  stringi::stri_split_fixed(method, ".")[[1]][1]
}

get_command <- function(method) {
  command <- stringi::stri_split_fixed(method, ".")[[1]][2]
  if (is.na(command)) 
    command <- ""
  command
}

list_domains <- function(protocol) {
  sapply(protocol$domains, function(x) x$domain)
}

check_domain <- function(protocol, domain) {
  domains <- list_domains(protocol)
  if (!any(domains == domain)) 
    stop(
      'domain "', domain, '" not found.\n', 
      'Execute list_domains() to get the list of domains.\n', 
      call. = FALSE
    )
}

get_domain_specs <- function(protocol, domain) {
  check_domain(protocol, domain)
  domains <- list_domains(protocol)
  protocol$domains[domains == domain][[1]]
}

describe_domain <- function(protocol, domain) {
  domain_specs <- get_domain_specs(protocol, domain)
  cat(domain_specs$description)
}

list_commands <- function(protocol, domain) {
  domain_specs <- get_domain_specs(protocol, domain)
  sapply(domain_specs$commands, function(x) x$name)
}

check_command <- function(protocol, domain, command) {
  commands <- list_commands(protocol, domain)
  if (!any(commands == command))
    stop(
      'command "', command, '" not available for domain "', domain, '".\n',
      'Execute list_commands() to get the list of commands.\n',
      call. = FALSE
    )
}

check_method <- function(protocol, method) {
  domain <- get_domain(method)
  command <- get_command(method)
  check_command(protocol, domain, command)
}

get_command_specs <- function(protocol, domain, command) {
  check_command(protocol, domain, command)
  domains <- list_domains(protocol)
  commands <- list_commands(protocol, domain)
  protocol$domains[domains == domain][[1]]$commands[commands == command][[1]]
}

get_method_specs <- function(protocol, method) {
  domain <- get_domain(method)
  command <- get_command(method)
  get_command_specs(protocol, domain, command)
}

describe_command <- function(protocol, domain, command) {
  command_specs <- get_command_specs(protocol, domain, command)
  cat(command_specs$description,
      "\nParameters:\n",
      sapply(command_specs$parameters, function(x) {
        optional <- if (is.null(x$optional)) FALSE else x$optional
        type <- if (is.null(x$type)) x[["$ref"]] else x$type 
        paste0(x$name, if (optional) " (optional)", ": ", x$description, " (type: ", type, ")\n")
      })
  )
}

describe_method <- function(protocol, method) {
  domain <- get_domain(method)
  command <- get_command(method)
  describe_command(protocol, domain, command)
}


# Sending commands through the DevTools protocol --------------------------

msg <- function(id, method, params = NULL) {
  data <- list(id = id, method = method)
  if(!is.null(params)) 
    data <- c(data, list(params = params))
  jsonlite::toJSON(data, auto_unbox = TRUE)
}

send <- (function() {
  id <- 0
  
  function(cnx, f, onmessage = NULL) {
    id <<- id + 1
    f <- substitute(f)
    method <- deparse(f[[1]])
    check_method(cnx$protocol, method)
    if (length(f) > 1) {
      params <- as.list(f)[2:length(f)]
    } else {
      params <- NULL
    }
    
    ws <- cnx$ws
    
    if (is.null(onmessage))
      onmessage <- function(id, data, resolve, reject) {
        if (!is.null(data$id)) {
          if (data$id == id) cat(sprintf("command %i received by Chrome\n", id))
          resolve(data)
        }
      }
    
    result <- promise(function(resolve, reject) {
      rm_onMsg <- NULL
      rm_onClose <- NULL
      rm_onError <- NULL
      rm_onMsg <- ws$onMessage(function(event) {
        resolve_and_remove_listeners <- function(x) {
          resolve(x)
          rm_onMsg()
          rm_onClose()
          rm_onError()
        } 
        reject_and_remove_listeners <- function(x) {
          reject(x)
          rm_onMsg()
          rm_onClose()
          rm_onError()
        }
        data <- jsonlite::fromJSON(event$data)
        if (!is.null(data$error)) 
          reject_and_remove_listeners(as.character(event$data))
        do.call(
          onmessage, 
          list(id = id, 
               data = data, 
               resolve = resolve_and_remove_listeners, 
               reject = reject_and_remove_listeners
          )
        )
      })
      rm_onClose <- ws$onClose(function(event) {
        reject(paste0("Client disconnected with code ", event$code,
                      " and reason ", event$reason))
        rm_onMsg()
        rm_onClose()
        rm_onError()
      })
      rm_onError <- ws$onError(function(event) {
        reject(paste0("Client failed to connect: ", event$message))
        rm_onMsg()
        rm_onClose()
        rm_onError()
      })
    })
    ws$send(msg(id, method, params))
    cat(sprintf("command %i sent to Chrome\n", id))
    result
  }
})()