├── .github ├── .gitignore └── workflows │ ├── render-readme.yaml │ ├── test-coverage.yaml │ ├── pkgdown.yaml │ └── R-CMD-check.yaml ├── vignettes ├── .gitignore ├── example1-screenshot.png └── intro.Rmd ├── LICENSE ├── .gitignore ├── tests ├── testthat.R ├── testthat │ ├── test-hold.R │ ├── test-helpers.R │ ├── helper-chrome.R │ ├── test-wait.R │ ├── test-CDProtocol.R │ ├── test-http_methods.R │ ├── test-EventEmitter.R │ ├── test-utils.R │ ├── test-Chrome.R │ └── test-cdpsession.R └── manual │ ├── chrome_execute.R │ ├── dumpDOM.R │ └── manual_test_CDP.R ├── R ├── zzz.R ├── helpers.R ├── reexport-promises.R ├── hold.R ├── wait.R ├── CDProtocol.R ├── domain.R ├── http_methods.R ├── utils.R ├── EventEmitter.R ├── CDPRemote.R └── CDPSession.R ├── codecov.yml ├── .Rbuildignore ├── tools ├── update.R └── generator.R ├── crrri.Rproj ├── man ├── write_base64.Rd ├── timeout.Rd ├── find_chrome_binary.Rd ├── hold.Rd ├── wait.Rd ├── reexports.Rd ├── CDPSession.Rd ├── http-methods.Rd ├── perform_with_chrome.Rd ├── CDPRemote.Rd ├── Chrome.Rd └── EventEmitter.Rd ├── _pkgdown.yml ├── LICENSE.md ├── NAMESPACE ├── DESCRIPTION ├── README.Rmd └── README.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | !dumpDOM.html 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2018 2 | COPYRIGHT HOLDER: Romain Lesur, Christophe Dervieux 3 | -------------------------------------------------------------------------------- /vignettes/example1-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RLesur/crrri/HEAD/vignettes/example1-screenshot.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Meta 2 | doc 3 | inst/doc 4 | .Rproj.user 5 | .Rhistory 6 | .RData 7 | .Ruserdata 8 | .Renviron 9 | docs/ 10 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(crrri) 3 | 4 | # do no print command from chrome launching 5 | options(crrri.verbose = FALSE) 6 | test_check("crrri") 7 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | ## nocov start 2 | 3 | .onLoad <- function(libname, pkgname) { 4 | if(requireNamespace("debugme", quietly = TRUE)) debugme::debugme() 5 | } 6 | 7 | ## nocov end 8 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | patch: 10 | default: 11 | target: auto 12 | threshold: 1% 13 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^codecov\.yml$ 2 | ^\.travis\.yml$ 3 | ^Meta$ 4 | ^doc$ 5 | ^README\.Rmd$ 6 | ^LICENSE\.md$ 7 | ^tools$ 8 | ^.*\.Rproj$ 9 | ^\.Rproj\.user$ 10 | ^\.Renviron$ 11 | ^_pkgdown\.yml$ 12 | ^docs$ 13 | ^pkgdown$ 14 | ^\.github$ 15 | -------------------------------------------------------------------------------- /tools/update.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | update_protocol <- function() { 3 | writeLines(readLines("https://raw.githubusercontent.com/ChromeDevTools/devtools-protocol/master/json/js_protocol.json"), 4 | here::here("inst/protocol/js_protocol.json")) 5 | writeLines(readLines("https://raw.githubusercontent.com/ChromeDevTools/devtools-protocol/master/json/browser_protocol.json"), 6 | here::here("inst/protocol/browser_protocol.json")) 7 | } 8 | 9 | update_protocol() 10 | -------------------------------------------------------------------------------- /crrri.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --run-donttest 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /tests/testthat/test-hold.R: -------------------------------------------------------------------------------- 1 | context("test-hold") 2 | 3 | test_that("hold returns the async value", { 4 | value <- runif(1) 5 | expect_identical(hold(promises::promise_resolve(value)), value) 6 | }) 7 | 8 | test_that("hold throws an error when the promise is rejected", { 9 | expect_error(hold(promises::promise_reject("message")), regexp = "^message$") 10 | }) 11 | 12 | test_that("hold throws an error if the promise is pending when timeout expires", { 13 | pr <- promises::promise(function(resolve, reject) { 14 | ~ later::later(~ resolve(1), 10) 15 | }) 16 | expect_error(hold(pr, 0.1)) 17 | }) 18 | -------------------------------------------------------------------------------- /.github/workflows/render-readme.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | paths: 4 | - README.Rmd 5 | 6 | name: Render README 7 | 8 | jobs: 9 | render: 10 | name: Render README 11 | runs-on: macOS-latest 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: r-lib/actions/setup-r@v1 15 | - uses: r-lib/actions/setup-pandoc@v1 16 | - name: Install rmarkdown 17 | run: Rscript -e 'install.packages("rmarkdown")' 18 | - name: Render README 19 | run: Rscript -e 'rmarkdown::render("README.Rmd")' 20 | - name: Commit results 21 | run: | 22 | git commit README.md -m 'Re-build README.Rmd' || echo "No changes to commit" 23 | git push origin || echo "No changes to commit" 24 | -------------------------------------------------------------------------------- /man/write_base64.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helpers.R 3 | \name{write_base64} 4 | \alias{write_base64} 5 | \title{write base64 result to file} 6 | \usage{ 7 | write_base64(res, con) 8 | } 9 | \arguments{ 10 | \item{res}{A resulting list object with some \code{data} field containing base64 11 | encoded data. (like \href{https://chromedevtools.github.io/devtools-protocol/tot/Page#method-printToPDF}{\code{Page$printToPDF()}})} 12 | 13 | \item{con}{A \link[base:connections]{connection} object. See \link[base:readBin]{base::writeBin()}.} 14 | } 15 | \description{ 16 | This is a helper function to write some resulting data from chrome to file. 17 | It will: 18 | \itemize{ 19 | \item decode the base64 encoded raw data 20 | \item write to file using \link[base:readBin]{base::writeBin()} 21 | It will be useful for function like \href{https://chromedevtools.github.io/devtools-protocol/tot/Page#method-printToPDF}{\code{Page$printToPDF()}} 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /tests/testthat/test-helpers.R: -------------------------------------------------------------------------------- 1 | test_that("write_base64 only works if data field is present as string", { 2 | expect_error(write_base64(list(a = "aaaa")), regexp = "name.*data") 3 | expect_error(write_base64(list(data = 2236)), "not a string") 4 | expect_error(write_base64(list(data = c("aaa", "bbb"))), "not a string") 5 | dummy_res <- list(data = jsonlite::base64_enc("test")) 6 | temp_file <- tempfile() 7 | expect_invisible(write_base64(dummy_res, temp_file)) 8 | expect_true(file.exists(temp_file)) 9 | expect_identical(readChar(temp_file, 10), "test") 10 | unlink(temp_file) 11 | }) 12 | 13 | test_that("write_base64 works with async promise", { 14 | temp_file <- tempfile() 15 | res <- promises::promise_resolve( 16 | list(data = jsonlite::base64_enc("test")) 17 | ) %...>% { 18 | write_base64(., temp_file) 19 | } %...>% { 20 | expect_true(file.exists(temp_file)) 21 | expect_identical(readChar(temp_file, 10), "test") 22 | } %>% 23 | promises::finally(~ unlink(temp_file)) 24 | hold(res) 25 | }) 26 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | destination: docs 2 | url: https://rlesur.github.io/crrri 3 | template: 4 | params: 5 | bootswatch: simplex 6 | development: 7 | mode: unreleased 8 | reference: 9 | - title: Execute an asynchronous CDP flow 10 | contents: 11 | - starts_with("perform_with") 12 | - title: Promises utility functions 13 | desc: Functions to wait for promises 14 | contents: 15 | - hold 16 | - wait 17 | - timeout 18 | - title: Utility functions 19 | desc: Functions useful to handle chrome results 20 | contents: 21 | - write_base64 22 | - title: Find chrome 23 | desc: Useful if you need help finding your chrome binary 24 | contents: 25 | - find_chrome_binary 26 | - title: Chrome browser class 27 | desc: Functions to deal with running chrome 28 | contents: 29 | - Chrome 30 | - title: Chrome DevTools Protocol classes 31 | desc: Functions to play with the protocol 32 | contents: 33 | - starts_with("CDP") 34 | - title: EventEmitter 35 | desc: Class to deal with events 36 | contents: 37 | - EventEmitter 38 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | #' write base64 result to file 2 | #' 3 | #' This is a helper function to write some resulting data from chrome to file. 4 | #' It will: 5 | #' - decode the base64 encoded raw data 6 | #' - write to file using [base::writeBin()][base::readBin()] 7 | #' It will be useful for function like [`Page$printToPDF()`](https://chromedevtools.github.io/devtools-protocol/tot/Page#method-printToPDF) 8 | #' 9 | #' @param res A resulting list object with some `data` field containing base64 10 | #' encoded data. (like [`Page$printToPDF()`](https://chromedevtools.github.io/devtools-protocol/tot/Page#method-printToPDF)) 11 | #' @param con A [connection][base::connections] object. See [base::writeBin()][base::readBin()]. 12 | #' 13 | #' @export 14 | #' 15 | #' @importFrom jsonlite base64_dec 16 | write_base64 <- function(res, con) { 17 | assertthat::assert_that(assertthat::has_name(res, "data")) 18 | assertthat::assert_that(assertthat::is.string(res$data)) 19 | decoded_res <- jsonlite::base64_dec(res$data) 20 | writeBin(decoded_res, con = con) 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/helper-chrome.R: -------------------------------------------------------------------------------- 1 | skip_if_not_chrome <- function() { 2 | if (nzchar(Sys.getenv("HEADLESS_CHROME"))) { 3 | return(invisible(TRUE)) 4 | } 5 | testthat::skip("Chrome is required to run this tests\nand is not available in the current testing environment.") 6 | } 7 | 8 | setup_chrome_test <- function(env = rlang::caller_env()) { 9 | skip_if_not_chrome() 10 | # create chrome object in the test environment 11 | setup({ 12 | capture.output( 13 | rlang::env_bind(.env = env, chrome = Chrome$new()) 14 | ) 15 | }, 16 | # we need this because these function are normally called in the test file directly 17 | env = env) 18 | # close connection and delete object after the test 19 | teardown({ 20 | if (chrome$is_alive()) { 21 | chrome$close() 22 | } 23 | # Env corresponding to test env where chrome is, is the parent env 24 | rlang::env_unbind(env = rlang::env_parent(), nms = "chrome") 25 | }, 26 | # we need this because these function are normally called in the test file directly 27 | env = env) 28 | } 29 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2018 Romain Lesur, Christophe Dervieux 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /man/timeout.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/wait.R 3 | \name{timeout} 4 | \alias{timeout} 5 | \title{Set a timeout} 6 | \usage{ 7 | timeout( 8 | x = NULL, 9 | delay = 0, 10 | msg = paste("The delay of", delay, "seconds expired.\\n") 11 | ) 12 | } 13 | \arguments{ 14 | \item{x}{An object.} 15 | 16 | \item{delay}{Number of seconds before rejecting the promise.} 17 | 18 | \item{msg}{Message if the timeout expires.} 19 | } 20 | \value{ 21 | A promise which fulfills when \code{x} fulfills before the delay expires: 22 | in this case, the value of the returned promise is the value of \code{x}. If 23 | \code{x} is not a fulfilled promise when the delay expires, the returned promise 24 | is rejected. 25 | } 26 | \description{ 27 | This is a helper function to set a timeout on a promise. It is designed to 28 | be used with the \code{magrittr} pipe \verb{\%>\%}. 29 | } 30 | \examples{ 31 | \dontrun{ 32 | library(promises) 33 | 34 | value <- runif(1) 35 | pr <- promise(function(resolve, reject) ~ later::later(~ resolve(value), 0.1)) 36 | 37 | pr \%>\% 38 | timeout(10) \%...>\% 39 | { cat("value: ", ., "\n") } \%...!\% 40 | { cat("error:", .$message, "\n") } 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /man/find_chrome_binary.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Chrome.R 3 | \name{find_chrome_binary} 4 | \alias{find_chrome_binary} 5 | \title{Find Google Chrome binary in the system} 6 | \usage{ 7 | find_chrome_binary() 8 | } 9 | \value{ 10 | A character string. The path the chrome binary that will 11 | be used by \code{crrri}. 12 | } 13 | \description{ 14 | If the chrome binary path has not already been set in \var{HEADLESS_CHROME} 15 | environment variable, the function will try to find the chrome binary 16 | on your system using a some hints. 17 | } 18 | \details{ 19 | \subsection{Windows}{ 20 | 21 | It will look in the registry for an installed version 22 | } 23 | 24 | \subsection{macOS,}{ 25 | 26 | It will return a hard-coded path of Chrome under \file{/Applications}. 27 | } 28 | 29 | \subsection{Linux,}{ 30 | 31 | It will search for \command{chromium-browser} and \command{google-chrome} from 32 | the system's \var{PATH} variable. 33 | } 34 | } 35 | \references{ 36 | From \code{pagedown} R package, licence MIT. \href{https://github.com/rstudio/pagedown/blob/b93f46fc1ad70182e5dd3d9fc843f752fd12f780/R/chrome.R#L213}{Source on Github} 37 | } 38 | \author{ 39 | Yihui Xie, Romain Lesur, Christophe Dervieux 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test-wait.R: -------------------------------------------------------------------------------- 1 | context("test-wait") 2 | 3 | test_that("wait(): both pipes work with a promise as an argument", { 4 | value <- runif(1) 5 | pr <- promises::promise_resolve(value) 6 | 7 | with_magrittr_pipe <- 8 | pr %>% wait(0.1) 9 | 10 | expect_identical(hold(with_magrittr_pipe), value) 11 | 12 | with_promises_pipe <- 13 | pr %...>% wait(0.1) 14 | 15 | expect_identical(hold(with_promises_pipe), value) 16 | }) 17 | 18 | test_that("wait() also works with a non-promise object", { 19 | value <- runif(1) 20 | pr <- wait(value, 0.1) 21 | expect_is(pr, "promise") 22 | expect_identical(hold(pr), value) 23 | }) 24 | 25 | test_that("timeout() works with a non promise argument", { 26 | value <- runif(1) 27 | pr <- timeout(x = value, delay = 0.1) 28 | expect_is(pr, "promise") 29 | expect_error(hold(pr), regexp = "0\\.1") 30 | }) 31 | 32 | test_that("timeout() returns the value of the promise when it is fulfilled before the delay expires", { 33 | value <- runif(1) 34 | pr <- timeout(wait(x = value, delay = 0.1), delay = 10) 35 | expect_is(pr, "promise") 36 | expect_identical(hold(pr), value) 37 | }) 38 | 39 | test_that("timeout() returns a promise which is rejected when the delay expires", { 40 | value <- runif(1) 41 | pr <- timeout(wait(x = value, delay = 10), delay = 0.1) 42 | expect_is(pr, "promise") 43 | expect_error(hold(pr), regexp = "0\\.1") 44 | }) 45 | 46 | -------------------------------------------------------------------------------- /man/hold.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hold.R 3 | \name{hold} 4 | \alias{hold} 5 | \title{Hold while an asynchronous task runs} 6 | \usage{ 7 | hold( 8 | x, 9 | timeout = 30, 10 | msg = paste("The asynchronous job has not finished in the delay of", timeout, 11 | "seconds.") 12 | ) 13 | } 14 | \arguments{ 15 | \item{x}{A \code{\link[promises:promise]{promises::promise()}} object.} 16 | 17 | \item{timeout}{Number scalar, timeout in seconds. An error is thrown if the 18 | promise is still pending when the delay expires.} 19 | 20 | \item{msg}{Error message when the timeout expires.} 21 | } 22 | \value{ 23 | The value of the promise once resolved. 24 | } 25 | \description{ 26 | The \code{hold()} function is a helper to turn a \code{\link[promises:promise]{promises::promise()}} in a 27 | synchronous value: the R session awaits the fulfillment of the promise 28 | and returns the value of the fulfilled promise. An error is thrown if the 29 | promise is rejected or a timeout expires. This is a wrapper around 30 | \code{\link[later:run_now]{later::run_now()}}. 31 | } 32 | \details{ 33 | This function must not be used inside a function that returns a promise. 34 | Otherwise, this will lead to an infinite loop. 35 | } 36 | \examples{ 37 | \dontrun{ 38 | 39 | library(promises) 40 | library(later) 41 | 42 | pr <- promise(~ later(~ resolve("result of the async task"), 1)) 43 | value <- hold(pr) 44 | cat(value, "\n") 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /man/wait.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/wait.R 3 | \name{wait} 4 | \alias{wait} 5 | \title{Return a promise after a delay} 6 | \usage{ 7 | wait(x, delay = 0) 8 | } 9 | \arguments{ 10 | \item{x}{An object.} 11 | 12 | \item{delay}{Number of seconds before resolving the promise.} 13 | } 14 | \value{ 15 | A \link[promises:promise]{promise}. See details for the value of the 16 | fulfilled promise. 17 | } 18 | \description{ 19 | This is a helper function that returns a \link[promises:promise]{promise} after 20 | a delay. It can be used with any pipe and any object (see examples). 21 | } 22 | \details{ 23 | The value of the returned promise depends on the class of \code{x}. If \code{x} can 24 | be coerced to a \link[promises:promise]{promise} (using 25 | \link[promises:is.promise]{promises::as.promise()}), the value of the returned 26 | promise is identical to the value of \code{promises::as.promise(x)} once 27 | fulfilled; otherwise the value of the returned promise is \code{x} after the 28 | delay. 29 | } 30 | \examples{ 31 | \dontrun{ 32 | library(promises) 33 | 34 | value <- runif(1) 35 | pr <- promise_resolve(value) 36 | 37 | # works with `magrittr` pipe 38 | pr \%>\% 39 | wait(1) \%>\% 40 | then(~ cat(., "\n")) 41 | 42 | # works with `promises` pipe 43 | pr \%...>\% 44 | wait(1) \%...>\% 45 | { cat(., "\n") } 46 | 47 | # also works with any object 48 | value \%>\% 49 | wait(1) \%>\% 50 | then(~cat(., "\n")) 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - master 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: macOS-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | steps: 17 | - uses: actions/checkout@v2 18 | 19 | - uses: r-lib/actions/setup-r@master 20 | 21 | - uses: r-lib/actions/setup-pandoc@master 22 | 23 | - name: Query dependencies 24 | run: | 25 | install.packages('remotes') 26 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 27 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 28 | shell: Rscript {0} 29 | 30 | - name: Cache R packages 31 | uses: actions/cache@v1 32 | with: 33 | path: ${{ env.R_LIBS_USER }} 34 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 35 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 36 | 37 | - name: Install dependencies 38 | run: | 39 | install.packages(c("remotes")) 40 | remotes::install_deps(dependencies = TRUE) 41 | remotes::install_cran("covr") 42 | shell: Rscript {0} 43 | 44 | - name: Test coverage 45 | run: covr::codecov() 46 | shell: Rscript {0} 47 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: master 4 | 5 | name: pkgdown 6 | 7 | jobs: 8 | pkgdown: 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - uses: r-lib/actions/setup-r@master 16 | 17 | - uses: r-lib/actions/setup-pandoc@master 18 | 19 | - name: Query dependencies 20 | run: | 21 | install.packages('remotes') 22 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 23 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 24 | shell: Rscript {0} 25 | 26 | - name: Cache R packages 27 | uses: actions/cache@v1 28 | with: 29 | path: ${{ env.R_LIBS_USER }} 30 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 31 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 32 | 33 | - name: Install dependencies 34 | run: | 35 | install.packages("remotes") 36 | remotes::install_deps(dependencies = TRUE) 37 | remotes::install_dev("pkgdown") 38 | shell: Rscript {0} 39 | 40 | - name: Install package 41 | run: R CMD INSTALL . 42 | 43 | - name: Deploy package 44 | run: pkgdown::deploy_to_branch(new_process = FALSE) 45 | shell: Rscript {0} 46 | -------------------------------------------------------------------------------- /man/reexports.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/reexport-promises.R 3 | \docType{import} 4 | \name{reexports} 5 | \alias{reexports} 6 | \alias{promise} 7 | \alias{promise_all} 8 | \alias{promise_map} 9 | \alias{promise_race} 10 | \alias{promise_reduce} 11 | \alias{promise_reject} 12 | \alias{promise_resolve} 13 | \alias{then} 14 | \alias{catch} 15 | \alias{finally} 16 | \alias{as.promise} 17 | \alias{is.promise} 18 | \alias{is.promising} 19 | \alias{\%>\%} 20 | \alias{\%T>\%} 21 | \alias{\%...>\%} 22 | \alias{\%...T>\%} 23 | \alias{\%...!\%} 24 | \alias{\%...T!\%} 25 | \title{Objects exported from other packages} 26 | \keyword{internal} 27 | \description{ 28 | These objects are imported from other packages. Follow the links 29 | below to see their documentation. 30 | 31 | \describe{ 32 | \item{promises}{\code{\link[promises]{\%...!\%}}, \code{\link[promises]{\%...>\%}}, \code{\link[promises]{\%...T!\%}}, \code{\link[promises]{\%...T>\%}}, \code{\link[promises]{\%>\%}}, \code{\link[promises]{\%T>\%}}, \code{\link[promises]{as.promise}}, \code{\link[promises]{catch}}, \code{\link[promises]{finally}}, \code{\link[promises]{is.promise}}, \code{\link[promises]{is.promising}}, \code{\link[promises]{promise}}, \code{\link[promises]{promise_all}}, \code{\link[promises]{promise_map}}, \code{\link[promises]{promise_race}}, \code{\link[promises]{promise_reduce}}, \code{\link[promises]{promise_reject}}, \code{\link[promises]{promise_resolve}}, \code{\link[promises]{then}}} 33 | }} 34 | 35 | -------------------------------------------------------------------------------- /tests/manual/chrome_execute.R: -------------------------------------------------------------------------------- 1 | devtools::load_all(".") 2 | pdf_rproject <- function(client) { 3 | Page <- client$Page 4 | 5 | Page$enable() %...>% { # await enablement of the Page domain 6 | Page$navigate(url = "https://www.r-project.org/") 7 | Page$loadEventFired() # await the load event 8 | } %...>% { 9 | Page$printToPDF() 10 | } %...>% { # await PDF reception 11 | write_base64(., "r_project.pdf") 12 | } 13 | } 14 | 15 | pdf_rstudio <- function(client) { 16 | Page <- client$Page 17 | 18 | Page$enable() %...>% { # await enablement of the Page domain 19 | Page$navigate(url = "https://rstudio.com/") 20 | Page$loadEventFired() # await the load event 21 | } %...>% { 22 | Page$printToPDF() 23 | } %...>% { # await PDF reception 24 | write_base64(., "rstudio.pdf") 25 | } 26 | } 27 | 28 | perform_with_chrome(pdf_rproject) 29 | 30 | perform_with_chrome(pdf_rproject, pdf_rstudio) 31 | 32 | async_save_as_pdf <- function(url) { 33 | function(client) { 34 | Page <- client$Page 35 | 36 | Page$enable() %...>% { 37 | Page$navigate(url = url) 38 | Page$loadEventFired() 39 | } %...>% { 40 | Page$printToPDF() 41 | } %...>% 42 | write_base64(paste0(httr::parse_url(url)$hostname, ".pdf")) 43 | } 44 | } 45 | 46 | save_as_pdf <- function(...) { 47 | list(...) %>% 48 | purrr::map(async_save_as_pdf) %>% 49 | perform_with_chrome(.list = .) 50 | } 51 | 52 | save_as_pdf("https://www.r-project.org/", "https://rstudio.com/") 53 | 54 | maf = function(client) {promises::promise_resolve(1)} 55 | 56 | a= perform_with_chrome(maf) 57 | -------------------------------------------------------------------------------- /R/reexport-promises.R: -------------------------------------------------------------------------------- 1 | #' @importFrom promises promise 2 | #' @export 3 | promises::promise 4 | 5 | #' @importFrom promises promise_all 6 | #' @export 7 | promises::promise_all 8 | 9 | #' @importFrom promises promise_map 10 | #' @export 11 | promises::promise_map 12 | 13 | #' @importFrom promises promise_race 14 | #' @export 15 | promises::promise_race 16 | 17 | #' @importFrom promises promise_reduce 18 | #' @export 19 | promises::promise_reduce 20 | 21 | #' @importFrom promises promise_reject 22 | #' @export 23 | promises::promise_reject 24 | 25 | #' @importFrom promises promise_resolve 26 | #' @export 27 | promises::promise_resolve 28 | 29 | #' @importFrom promises then 30 | #' @export 31 | promises::then 32 | 33 | #' @importFrom promises catch 34 | #' @export 35 | promises::catch 36 | 37 | #' @importFrom promises finally 38 | #' @export 39 | promises::finally 40 | 41 | #' @importFrom promises as.promise 42 | #' @export 43 | promises::as.promise 44 | 45 | #' @importFrom promises is.promise 46 | #' @export 47 | promises::is.promise 48 | 49 | #' @importFrom promises is.promising 50 | #' @export 51 | promises::is.promising 52 | 53 | # Pipe operators ------------------ 54 | 55 | #' @importFrom promises %>% 56 | #' @export 57 | promises::`%>%` 58 | 59 | #' @importFrom promises %T>% 60 | #' @export 61 | promises::`%T>%` 62 | 63 | #' @importFrom promises %...>% 64 | #' @export 65 | promises::`%...>%` 66 | 67 | #' @importFrom promises %...T>% 68 | #' @export 69 | promises::`%...T>%` 70 | 71 | #' @importFrom promises %...!% 72 | #' @export 73 | promises::`%...!%` 74 | 75 | #' @importFrom promises %...T!% 76 | #' @export 77 | promises::`%...T!%` 78 | 79 | -------------------------------------------------------------------------------- /man/CDPSession.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CDPSession.R 3 | \name{CDPSession} 4 | \alias{CDPSession} 5 | \title{Connect to a remote instance implementing the Chrome Debugging Protocol} 6 | \usage{ 7 | CDPSession( 8 | host = "localhost", 9 | port = 9222, 10 | secure = FALSE, 11 | ws_url = NULL, 12 | local = FALSE, 13 | callback = NULL 14 | ) 15 | } 16 | \arguments{ 17 | \item{host}{Character scalar, the host name of the application.} 18 | 19 | \item{port}{The remote debugging port (a numeric or a character scalar).} 20 | 21 | \item{secure}{A logical indicating whether a secure protocol shall be used.} 22 | 23 | \item{ws_url}{Character scalar, the websocket URL. If provided, \code{host} and 24 | \code{port} arguments are ignored.} 25 | 26 | \item{local}{Logical scalar, indicating whether the local version of the 27 | protocol (embedded in \code{crrri}) must be used or the protocol must be 28 | fetched \emph{remotely}.} 29 | 30 | \item{callback}{Function with one argument, executed when the R session is 31 | connected to Chrome. The connection object is passed to this function.} 32 | } 33 | \value{ 34 | The returned value depends on the value of the \code{callback} argument. 35 | When \code{callback} is a function, the returned value is a connection object 36 | of class \code{CDPSession}. When \code{callback} is \code{NULL} the returned value is 37 | a promise which becomes fulfilled once R is connected to the remote 38 | instance. Once fulfilled, the value of this promise is the connection 39 | object of class \code{CDPSession}. 40 | } 41 | \description{ 42 | This function creates a websocket connection to a remote instance using 43 | the Chrome Debugging Protocol. 44 | } 45 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export("%...!%") 4 | export("%...>%") 5 | export("%...T!%") 6 | export("%...T>%") 7 | export("%>%") 8 | export("%T>%") 9 | export(CDPRemote) 10 | export(CDPSession) 11 | export(Chrome) 12 | export(EventEmitter) 13 | export(activate_target) 14 | export(as.promise) 15 | export(catch) 16 | export(close_target) 17 | export(fetch_protocol) 18 | export(fetch_version) 19 | export(finally) 20 | export(find_chrome_binary) 21 | export(hold) 22 | export(inspect_target) 23 | export(is.promise) 24 | export(is.promising) 25 | export(list_targets) 26 | export(new_tab) 27 | export(perform_with_chrome) 28 | export(promise) 29 | export(promise_all) 30 | export(promise_map) 31 | export(promise_race) 32 | export(promise_reduce) 33 | export(promise_reject) 34 | export(promise_resolve) 35 | export(then) 36 | export(timeout) 37 | export(wait) 38 | export(write_base64) 39 | importFrom(assertthat,assert_that) 40 | importFrom(assertthat,is.number) 41 | importFrom(assertthat,is.scalar) 42 | importFrom(jsonlite,base64_dec) 43 | importFrom(promises,"%...!%") 44 | importFrom(promises,"%...>%") 45 | importFrom(promises,"%...T!%") 46 | importFrom(promises,"%...T>%") 47 | importFrom(promises,"%>%") 48 | importFrom(promises,"%T>%") 49 | importFrom(promises,as.promise) 50 | importFrom(promises,catch) 51 | importFrom(promises,finally) 52 | importFrom(promises,is.promise) 53 | importFrom(promises,is.promising) 54 | importFrom(promises,promise) 55 | importFrom(promises,promise_all) 56 | importFrom(promises,promise_map) 57 | importFrom(promises,promise_race) 58 | importFrom(promises,promise_reduce) 59 | importFrom(promises,promise_reject) 60 | importFrom(promises,promise_resolve) 61 | importFrom(promises,then) 62 | importFrom(rlang,`%||%`) 63 | -------------------------------------------------------------------------------- /tests/manual/dumpDOM.R: -------------------------------------------------------------------------------- 1 | # from a question https://community.rstudio.com/t/webscarping-rvest-output-list-of-0/29625 2 | 3 | # Using CRRRI 4 | 5 | devtools::load_all() 6 | 7 | # does not dump the correct DOM 8 | # keeping just for example 9 | dump_DOM2 <- function(url) { 10 | # require for crrri to be configured to find chrom 11 | chrome <- Chrome$new() 12 | on.exit(chrome$close()) 13 | client <- hold(chrome$connect()) 14 | Page <- client$Page 15 | DOM <- client$DOM 16 | Page$enable() %...>% { 17 | DOM$enable() 18 | } %...>% { 19 | Page$navigate(url) 20 | Page$loadEventFired() 21 | } %...>% { 22 | DOM$getDocument() 23 | } %...>% { 24 | DOM$getOuterHTML(nodeId = .$root$nodeId) 25 | } %>% { 26 | hold(.)$outerHTML 27 | } 28 | } 29 | 30 | dump_DOM <- function(url) { 31 | # require for crrri to be configured to find chrom 32 | chrome <- Chrome$new() 33 | on.exit(chrome$close()) 34 | client <- hold(chrome$connect()) 35 | Network <- client$Network 36 | Page <- client$Page 37 | Runtime <- client$Runtime 38 | Page$enable() %...>% { 39 | Network$enable() 40 | } %...>% { 41 | Network$setCacheDisabled(cacheDisabled = TRUE) 42 | } %...>% { 43 | Page$navigate(url) 44 | } %...>% { 45 | Page$loadEventFired() 46 | } %...>% { 47 | Runtime$evaluate( 48 | expression = 'document.documentElement.outerHTML' 49 | ) 50 | } %>% { 51 | hold(.)$result$value 52 | } 53 | } 54 | 55 | dom <- dump_DOM(url = "https://sofifa.com/player/230621") 56 | library(rvest) 57 | html <- read_html(dom) 58 | nb_nodes <- html %>% 59 | html_nodes("#version-jump > option") %>% 60 | length() 61 | testthat::expect_gt(nb_nodes, 1) 62 | 63 | html %>% html_node("#version-jump > option:nth-child(1)") %>% html_text() 64 | html %>% html_node("#version-jump > option:nth-child(2)") %>% html_text() 65 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: crrri 2 | Type: Package 3 | Title: An Interface with Headless Chromium/Chrome 4 | Version: 0.0.13 5 | Authors@R: c( 6 | person("Romain", "Lesur", role = c("aut", "cre"), email = "romain.lesur@gmail.com", comment = c(ORCID = "0000-0002-0721-5595")), 7 | person("Christophe", "Dervieux", role = c("aut", "cph"), email = "christophe.dervieux@gmail.com", comment = c(ORCID = "0000-0003-4474-2498")), 8 | person("Miles", "McBain", role = "ctb", comment = "websocket connection functions"), 9 | person(family = "The Chromium authors", role = "ctb", comment = "DevTools Protocol documentation"), 10 | person("Yihui", "Xie", role = "ctb", comment = "function to find chrome on all OS") 11 | ) 12 | Maintainer: Romain Lesur 13 | Description: This is a native implementation of the Chrome DevTools Protocol. 14 | License: MIT + file LICENSE 15 | URL: https://rlesur.github.io/crrri/, https://github.com/RLesur/crrri 16 | BugReports: https://github.com/RLesur/crrri/issues 17 | SystemRequirements: Chromium or Chrome 18 | Imports: 19 | assertthat, 20 | httpuv (>= 1.5.0), 21 | httr, 22 | jsonlite, 23 | later, 24 | processx, 25 | promises, 26 | purrr, 27 | rlang (>= 0.3.0), 28 | R6, 29 | utils, 30 | websocket, 31 | rappdirs 32 | Suggests: 33 | debugme, 34 | knitr, 35 | rmarkdown, 36 | testthat (>= 2.1.0), 37 | covr, 38 | rstudioapi, 39 | withr 40 | Encoding: UTF-8 41 | LazyData: true 42 | Roxygen: list(markdown = TRUE, load = 'source') 43 | RoxygenNote: 7.1.0 44 | VignetteBuilder: knitr 45 | Collate: 46 | 'wait.R' 47 | 'hold.R' 48 | 'utils.R' 49 | 'http_methods.R' 50 | 'CDProtocol.R' 51 | 'reexport-promises.R' 52 | 'domain.R' 53 | 'EventEmitter.R' 54 | 'CDPSession.R' 55 | 'CDPRemote.R' 56 | 'Chrome.R' 57 | 'helpers.R' 58 | 'zzz.R' 59 | -------------------------------------------------------------------------------- /R/hold.R: -------------------------------------------------------------------------------- 1 | #' @importFrom assertthat assert_that is.number 2 | #' @include wait.R 3 | NULL 4 | 5 | #' Hold while an asynchronous task runs 6 | #' 7 | #' The `hold()` function is a helper to turn a [promises::promise()] in a 8 | #' synchronous value: the R session awaits the fulfillment of the promise 9 | #' and returns the value of the fulfilled promise. An error is thrown if the 10 | #' promise is rejected or a timeout expires. This is a wrapper around 11 | #' [later::run_now()]. 12 | #' 13 | #' This function must not be used inside a function that returns a promise. 14 | #' Otherwise, this will lead to an infinite loop. 15 | #' 16 | #' @param x A [promises::promise()] object. 17 | #' @param timeout Number scalar, timeout in seconds. An error is thrown if the 18 | #' promise is still pending when the delay expires. 19 | #' @param msg Error message when the timeout expires. 20 | #' 21 | #' @return The value of the promise once resolved. 22 | #' @export 23 | #' 24 | #' @examples 25 | #' \dontrun{ 26 | #' 27 | #' library(promises) 28 | #' library(later) 29 | #' 30 | #' pr <- promise(~ later(~ resolve("result of the async task"), 1)) 31 | #' value <- hold(pr) 32 | #' cat(value, "\n") 33 | #' } 34 | hold <- function(x, timeout = 30, msg = paste("The asynchronous job has not finished in the delay of", timeout, "seconds.")) { 35 | x <- promises::as.promise(x) 36 | assert_that(is.number(timeout)) 37 | 38 | promise <- timeout(x, delay = timeout, msg = msg) 39 | 40 | state <- new.env() 41 | state$pending <- TRUE 42 | 43 | promises::then( 44 | promise, 45 | onFulfilled = function(value) { 46 | state$pending <- FALSE 47 | state$fulfilled <- TRUE 48 | state$value <- value 49 | }, 50 | onRejected = function(error) { 51 | state$pending <- FALSE 52 | state$fulfilled <- FALSE 53 | state$reason <- error 54 | } 55 | ) 56 | 57 | while(state$pending) { 58 | later::run_now(all=FALSE) 59 | } 60 | 61 | if (state$fulfilled) { 62 | return(state$value) 63 | } else { 64 | stop(state$reason) 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - master 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - {os: windows-latest, r: 'release'} 22 | - {os: macOS-latest, r: 'release'} 23 | - {os: macOS-latest, r: 'devel'} 24 | - {os: ubuntu-16.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 25 | 26 | env: 27 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 28 | RSPM: ${{ matrix.config.rspm }} 29 | 30 | steps: 31 | - uses: actions/checkout@v2 32 | 33 | - uses: r-lib/actions/setup-r@master 34 | with: 35 | r-version: ${{ matrix.config.r }} 36 | 37 | - uses: r-lib/actions/setup-pandoc@master 38 | 39 | - name: Query dependencies 40 | run: | 41 | install.packages('remotes') 42 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 43 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 44 | shell: Rscript {0} 45 | 46 | - name: Cache R packages 47 | if: runner.os != 'Windows' 48 | uses: actions/cache@v1 49 | with: 50 | path: ${{ env.R_LIBS_USER }} 51 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 52 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 53 | 54 | - name: Install system dependencies 55 | if: runner.os == 'Linux' 56 | env: 57 | RHUB_PLATFORM: linux-x86_64-ubuntu-gcc 58 | run: | 59 | Rscript -e "remotes::install_github('r-hub/sysreqs')" 60 | sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))") 61 | sudo -s eval "$sysreqs" 62 | 63 | - name: Install dependencies 64 | run: | 65 | remotes::install_deps(dependencies = TRUE) 66 | remotes::install_cran("rcmdcheck") 67 | shell: Rscript {0} 68 | 69 | - name: Check 70 | env: 71 | _R_CHECK_CRAN_INCOMING_REMOTE_: false 72 | run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") 73 | shell: Rscript {0} 74 | 75 | - name: Upload check results 76 | if: failure() 77 | uses: actions/upload-artifact@master 78 | with: 79 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 80 | path: check 81 | -------------------------------------------------------------------------------- /man/http-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/http_methods.R 3 | \name{http-methods} 4 | \alias{http-methods} 5 | \alias{fetch_version} 6 | \alias{list_targets} 7 | \alias{fetch_protocol} 8 | \alias{new_tab} 9 | \alias{activate_target} 10 | \alias{close_target} 11 | \alias{inspect_target} 12 | \title{Chrome Debugging Protocol HTTP methods} 13 | \usage{ 14 | fetch_version(host = "localhost", port = 9222, secure = FALSE) 15 | 16 | list_targets(host = "localhost", port = 9222, secure = FALSE) 17 | 18 | fetch_protocol(host = "localhost", port = 9222, secure = FALSE, local = FALSE) 19 | 20 | new_tab(host = "localhost", port = 9222, secure = FALSE, url = NULL) 21 | 22 | activate_target(host = "localhost", port = 9222, secure = FALSE, target_id) 23 | 24 | close_target(host = "localhost", port = 9222, secure = FALSE, target_id) 25 | 26 | inspect_target(host = "localhost", port = 9222, secure = FALSE, target_id) 27 | } 28 | \arguments{ 29 | \item{host}{Character scalar, the host name of the application.} 30 | 31 | \item{port}{The remote debugging port (a numeric or a character scalar).} 32 | 33 | \item{secure}{A logical indicating whether a secure protocol shall be used.} 34 | 35 | \item{local}{Logical scalar, indicating whether the local version of the 36 | protocol (embedded in \code{crrri}) must be used or the protocol must be 37 | fetched \emph{remotely}.} 38 | 39 | \item{url}{URL to open in a new tab.} 40 | 41 | \item{target_id}{Target (or tab) identifier.} 42 | } 43 | \value{ 44 | \code{fetch_version()}, \code{list_targets()}, \code{fetch_protocols()} and 45 | \code{new_tab()} return a list. \code{activate_target()} and \code{close_target()} returns 46 | a logical: \code{TRUE} is returned when the command succeeds, \code{FALSE} is 47 | returned if a wrong \code{target_id} is provided. 48 | } 49 | \description{ 50 | When Chromium/Chrome is started in debugging mode, several HTTP endpoints 51 | are available. Using these endpoint, one can retrieve information from 52 | Chromium/Chrome or send commands, see 53 | \url{https://chromedevtools.github.io/devtools-protocol/#endpoints}. 54 | } 55 | \examples{ 56 | \dontrun{ 57 | chrome <- Chrome$new() 58 | 59 | # fetch information about headless Chrome 60 | fetch_version() 61 | # fetch the Chromium/Chrome protocol 62 | protocol <- fetch_protocol() 63 | 64 | # get the list of opened tabs 65 | list_targets() 66 | # open an url in a new tab 67 | new_target <- new_tab(url = "http://r-project.org") 68 | # the new tab is referenced in the list of opened tabs 69 | list_targets() 70 | # inspect a target in a web browser 71 | if(interactive()) inspect_target(target_id = new_target$id) 72 | # close the previous created tab 73 | close_target(target_id = new_target$id) 74 | 75 | chrome$close() 76 | } 77 | } 78 | \keyword{internal} 79 | -------------------------------------------------------------------------------- /R/wait.R: -------------------------------------------------------------------------------- 1 | #' Return a promise after a delay 2 | #' 3 | #' This is a helper function that returns a [promise][promises::promise] after 4 | #' a delay. It can be used with any pipe and any object (see examples). 5 | #' 6 | #' The value of the returned promise depends on the class of `x`. If `x` can 7 | #' be coerced to a [promise][promises::promise] (using 8 | #' [promises::as.promise()][promises::is.promise]), the value of the returned 9 | #' promise is identical to the value of `promises::as.promise(x)` once 10 | #' fulfilled; otherwise the value of the returned promise is `x` after the 11 | #' delay. 12 | #' 13 | #' @param x An object. 14 | #' @param delay Number of seconds before resolving the promise. 15 | #' 16 | #' @return A [promise][promises::promise]. See details for the value of the 17 | #' fulfilled promise. 18 | #' @export 19 | #' 20 | #' @examples 21 | #' \dontrun{ 22 | #' library(promises) 23 | #' 24 | #' value <- runif(1) 25 | #' pr <- promise_resolve(value) 26 | #' 27 | #' # works with `magrittr` pipe 28 | #' pr %>% 29 | #' wait(1) %>% 30 | #' then(~ cat(., "\n")) 31 | #' 32 | #' # works with `promises` pipe 33 | #' pr %...>% 34 | #' wait(1) %...>% 35 | #' { cat(., "\n") } 36 | #' 37 | #' # also works with any object 38 | #' value %>% 39 | #' wait(1) %>% 40 | #' then(~cat(., "\n")) 41 | #' } 42 | wait <- function(x, delay = 0) { 43 | # if x is not a promise or cannot be coerced to a promise, 44 | # consider that it is the value of a resolved promise: 45 | if(!promises::is.promising(x)) { 46 | x <- promises::promise_resolve(x) 47 | } 48 | 49 | promises::then( 50 | x, 51 | onFulfilled = function(value) { 52 | promises::promise(function(resolve, reject) { 53 | later::later(~ resolve(value), delay) 54 | }) 55 | } 56 | ) 57 | } 58 | 59 | #' Set a timeout 60 | #' 61 | #' This is a helper function to set a timeout on a promise. It is designed to 62 | #' be used with the `magrittr` pipe `%>%`. 63 | #' 64 | #' @param x An object. 65 | #' @param delay Number of seconds before rejecting the promise. 66 | #' @param msg Message if the timeout expires. 67 | #' 68 | #' @return A promise which fulfills when `x` fulfills before the delay expires: 69 | #' in this case, the value of the returned promise is the value of `x`. If 70 | #' `x` is not a fulfilled promise when the delay expires, the returned promise 71 | #' is rejected. 72 | #' @export 73 | #' @examples 74 | #' \dontrun{ 75 | #' library(promises) 76 | #' 77 | #' value <- runif(1) 78 | #' pr <- promise(function(resolve, reject) ~ later::later(~ resolve(value), 0.1)) 79 | #' 80 | #' pr %>% 81 | #' timeout(10) %...>% 82 | #' { cat("value: ", ., "\n") } %...!% 83 | #' { cat("error:", .$message, "\n") } 84 | #' } 85 | timeout <- function(x = NULL, delay = 0, msg = paste("The delay of", delay, "seconds expired.\n")) { 86 | reject_after_delay <- promises::promise(function(resolve, reject) { 87 | later::later(~ reject(simpleError(msg)), delay) 88 | }) 89 | 90 | if(!promises::is.promising(x)) { 91 | x <- reject_after_delay 92 | } 93 | 94 | promises::promise_race(x, reject_after_delay) 95 | } 96 | -------------------------------------------------------------------------------- /tests/manual/manual_test_CDP.R: -------------------------------------------------------------------------------- 1 | devtools::load_all() 2 | 3 | remote <- Chrome$new() 4 | client <- CDPSession() 5 | # client is in pre-connecting test until connection is explicitely launch 6 | client$readyState() 7 | 8 | # listening event 9 | client$once("Runtime.executionContextCreated", function(...) cat("First command passed!")) 10 | 11 | client$ 12 | once("connect", ~ client$send('Runtime.enable'))$ 13 | once("Runtime.enable", ~ client$send('Page.enable'))$ 14 | once("Page.enable", 15 | ~ client$send('Runtime.addBinding', 16 | params = list(name = "pagedownListener") 17 | ) 18 | )$ 19 | once("Runtime.addBinding", 20 | ~ client$send('Page.navigate', 21 | params = list(url = "https://pagedown.rbind.io") 22 | ) 23 | )$ 24 | once('Page.domContentEventFired', 25 | ~ client$send('Runtime.evaluate', 26 | params = list(expression = "!!window.PagedPolyfill") 27 | ) 28 | )$ 29 | once("Runtime.evaluate", 30 | function(result) if (!isTRUE(result$result$value)) { 31 | client$send( 32 | "Page.printToPDF", 33 | params = list(printBackground = TRUE, preferCSSPageSize = TRUE) 34 | ) 35 | } 36 | )$ 37 | once('Runtime.bindingCalled', 38 | ~ client$send( 39 | "Page.printToPDF", 40 | params = list(printBackground = TRUE, preferCSSPageSize = TRUE) 41 | ) 42 | )$ 43 | once("Page.printToPDF", 44 | function(result) writeBin(jsonlite::base64_dec(result$data), "test.pdf") 45 | ) 46 | 47 | # Lauching connection and starting the chain of event 48 | client$connect() 49 | 50 | # disconnect the client and close chrome 51 | client$disconnect() 52 | if(remote$is_alive()) remote$close() 53 | rm(list = ls()) 54 | gc() 55 | 56 | # New API with promises -------------------------------------- 57 | devtools::load_all() 58 | 59 | chrome <- Chrome$new() 60 | client <- hold(chrome$connect()) 61 | 62 | # client is connected and ready to receive commands 63 | client$readyState() 64 | 65 | Runtime <- client$Runtime 66 | Page <- client$Page 67 | 68 | print_pdf <- function(file = "test.pdf") { 69 | Page$printToPDF( 70 | printBackground = TRUE, 71 | preferCSSPageSize = TRUE 72 | ) %...>% ( 73 | function(result) { 74 | writeBin(jsonlite::base64_dec(result$data), file) 75 | file 76 | } 77 | ) 78 | } 79 | 80 | page_loaded <- Page$loadEventFired() 81 | 82 | print_standard_document <- function() { 83 | page_loaded %...>% { 84 | print_pdf() 85 | } 86 | } 87 | 88 | ready_to_navigate <- 89 | Runtime$enable() %...>% { 90 | Page$enable() 91 | } %...>% { 92 | Runtime$addBinding(name = "pagedownListener") 93 | } 94 | 95 | pagedjs_documents_printed <- 96 | Runtime$bindingCalled() %...>% { 97 | print_pdf() 98 | } 99 | 100 | printed <- 101 | ready_to_navigate %...>% { 102 | Page$navigate(url = "https://pagedown.rbind.io") 103 | } %...>% { 104 | Page$domContentEventFired() 105 | } %...>% { 106 | Runtime$evaluate(expression = "!!window.PagedPolyfill") 107 | } %...>% ( 108 | function(result) if(isTRUE(result$result$value)) { 109 | pagedjs_documents_printed 110 | } else { 111 | print_standard_document() 112 | } 113 | ) 114 | 115 | 116 | # closing the session and chrome 117 | if(remote$is_alive()) remote$close() 118 | rm(list = ls()) 119 | gc() 120 | -------------------------------------------------------------------------------- /man/perform_with_chrome.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Chrome.R 3 | \name{perform_with_chrome} 4 | \alias{perform_with_chrome} 5 | \title{Execute an asynchronous CDP flow with Chrome} 6 | \usage{ 7 | perform_with_chrome( 8 | ..., 9 | .list = NULL, 10 | timeouts = 30, 11 | cleaning_timeout = 30, 12 | async = FALSE, 13 | bin = NULL, 14 | debug_port = 9222L, 15 | local = FALSE, 16 | extra_args = NULL, 17 | headless = TRUE, 18 | retry_delay = 0.2, 19 | max_attempts = 15L 20 | ) 21 | } 22 | \arguments{ 23 | \item{...}{Asynchronous remote flow functions.} 24 | 25 | \item{.list}{A list of asynchronous remote flow functions - an alternative to 26 | \code{...}.} 27 | 28 | \item{timeouts}{A vector of timeouts applied to each asynchronous function. 29 | Repeated.} 30 | 31 | \item{cleaning_timeout}{The delay for cleaning Chrome.} 32 | 33 | \item{async}{Is the result a promise? Required for using \code{perform_with_chrome()} 34 | in Shiny.} 35 | 36 | \item{bin}{Character scalar, the path to Chromium or Chrome executable. 37 | If not provided, \code{crrri} will try to find the chrome binary itself using 38 | \code{find_chrome_binary()}. You can set a path in \code{HEADLESS_CHROME} environment 39 | variable to indicate where it is located.} 40 | 41 | \item{debug_port}{Integer scalar, the Chromium/Chrome remote debugging port.} 42 | 43 | \item{local}{Logical scalar, indicating whether the local version of the 44 | protocol (embedded in \code{crrri}) must be used or the protocol must be 45 | fetched \emph{remotely}.} 46 | 47 | \item{extra_args}{Character vector, extra command line arguments passed to 48 | Chromium/Chrome. You can know more about command line flags (or switches) 49 | from \href{https://www.chromium.org/developers/how-tos/run-chromium-with-flags}{chromium developers}} 50 | 51 | \item{headless}{Logical scalar, indicating whether Chromium/Chrome is launched 52 | in headless mode.} 53 | 54 | \item{retry_delay}{Number, delay in seconds between two successive tries to 55 | connect to headless Chromium/Chrome.} 56 | 57 | \item{max_attempts}{Logical scalar, number of tries to connect to headless 58 | Chromium/Chrome.} 59 | } 60 | \value{ 61 | An invisible list with the values of the fulfilled promises for each 62 | async function.d If there is only async function, the return value is the value of the 63 | fulfilled promise. 64 | } 65 | \description{ 66 | The \code{perform_with_chrome()} function executes an asynchronous Chrome DevTools 67 | Protocol flow with Chromium/Chrome and can turn it into a synchronous function. 68 | An asynchronous remote flow is a function that takes a connection object and 69 | returns a \link[promises:promise]{promise}. 70 | If several functions are passed to \code{perform_with_chrome()}, their execution is 71 | serial. If one of the asynchronous functions fails, the whole execution also 72 | fails. 73 | } 74 | \examples{ 75 | \dontrun{ 76 | async_save_as_pdf <- function(url) { 77 | function(client) { 78 | Page <- client$Page 79 | 80 | Page$enable() \%...>\% { 81 | Page$navigate(url = url) 82 | Page$loadEventFired() 83 | } \%...>\% { 84 | Page$printToPDF() 85 | } \%...>\% { 86 | write_base64(., paste0(httr::parse_url(url)$hostname, ".pdf")) 87 | } 88 | } 89 | } 90 | 91 | save_as_pdf <- function(...) { 92 | list(...) \%>\% 93 | purrr::map(async_save_as_pdf) \%>\% 94 | perform_with_chrome(.list = .) 95 | } 96 | 97 | save_as_pdf("https://www.r-project.org/", "https://rstudio.com/") 98 | } 99 | } 100 | -------------------------------------------------------------------------------- /tests/testthat/test-CDProtocol.R: -------------------------------------------------------------------------------- 1 | context("test-CDProtocol") 2 | 3 | test_that("rlist2env transform nested list to nested env", { 4 | .l <- list(a = list(b = 2), c = list(d = 3)) 5 | .env <- rlang::env(rlang::empty_env(), 6 | a = rlang::env(rlang::empty_env(), b = 2), 7 | c = rlang::env(rlang::empty_env(), d = 3)) 8 | expect_equal(rlist2env(.l), .env) 9 | }) 10 | 11 | test_that("renv2list transform nested environment to nested list", { 12 | .l <- list(a = list(b = 2), c = list(d = 3)) 13 | .env <- rlist2env(.l) 14 | .l2 <- renv2list(.env) 15 | expect_identical(.l, .l2) 16 | }) 17 | 18 | test_that("renv2list discard argument remove any object that is referenced by one of these names", { 19 | .l <- list(a = list(b = 2, remove_me = "a"), c = list(d = 3, remove_me_too = "b"), remove_me = 4) 20 | .exptd <- list(a = list(b = 2), c = list(d = 3)) 21 | .env <- rlist2env(.l) 22 | .l2 <- renv2list(.env, discard = c("remove_me", "remove_me_too")) 23 | expect_identical(.l2, .exptd) 24 | }) 25 | 26 | test_that("get_formals_* methods return a list", { 27 | protocol <- CDProtocol$new() 28 | expect_is(protocol$get_formals_for_command("Page", "navigate"), "list") 29 | expect_is(protocol$get_formals_for_event("Page", "loadEventFired"), "list") 30 | }) 31 | 32 | test_that("get_formals_* throws error if callback is present and returns correcly otherwise", { 33 | protocol <- CDProtocol$new() 34 | # create a dummy domain to add 35 | dummyDomain <- rlang::env( 36 | commands = rlang::env( 37 | dummy_cmd = rlang::env( 38 | parameters = rlang::env( 39 | callback = list(name = "callback", description = "callback") 40 | )), 41 | dummy_cmd2 = rlang::env( 42 | parameters = rlang::env( 43 | dummy_param2 = list(name = "dummy_param_opt", 44 | description = "dummy_desc option", 45 | optional = TRUE), 46 | dummy_param = list(name = "dummy_param", description = "dummy_dec") 47 | )) 48 | ), 49 | events = rlang::env( 50 | dummy_event = rlang::env( 51 | parameters = rlang::env( 52 | callback = list(name = "callback", description = "callback") 53 | ) 54 | ), 55 | dummy_event2 = rlang::env( 56 | parameters = rlang::env( 57 | dummy_param = list(name = "dummy_param", description = "dummy_desc"), 58 | dummy_param2 = list(name = "dummy_param2", 59 | description = "dummy_desc option") 60 | ) 61 | ) 62 | )) 63 | # this is hacky but works to test and not depend on the json protocol 64 | rlang::env_bind(.env = protocol$.__enclos_env__$private$.protocol$domains, 65 | dummyDomain = dummyDomain) 66 | expect_error(protocol$get_formals_for_command("dummyDomain", "dummy_cmd"), regexp = "callback") 67 | expect_error(protocol$get_formals_for_event("dummyDomain", "dummy_event"), regexp = "callback") 68 | expect_identical( 69 | protocol$get_formals_for_event("dummyDomain", "dummy_event2"), 70 | list(dummy_param = NULL, dummy_param2 = NULL, callback = NULL) 71 | ) 72 | expect_identical( 73 | protocol$get_formals_for_command("dummyDomain", "dummy_cmd2"), 74 | list(dummy_param = rlang::sym(""), dummy_param2 = NULL, callback = NULL) 75 | ) 76 | }) 77 | 78 | 79 | test_that("domain_description returns a string even if the domain has no description", { 80 | protocol <- CDProtocol$new() 81 | # create a dummy domain to add 82 | dummyDomain <- rlang::env() 83 | rlang::env_bind(.env = protocol$.__enclos_env__$private$.protocol$domains, 84 | dummyDomain = dummyDomain) 85 | expect_true("dummyDomain" %in% protocol$domains) 86 | expect_silent(purrr::map_chr(protocol$domains, protocol$domain_description)) 87 | }) 88 | -------------------------------------------------------------------------------- /tests/testthat/test-http_methods.R: -------------------------------------------------------------------------------- 1 | context("test-http-methods") 2 | 3 | # These tests can be run without Chrome 4 | 5 | test_that("fetch local protocol works and returns a list", { 6 | expect_is(fetch_protocol(local = TRUE), "list") 7 | }) 8 | 9 | test_that("fetch_protocol() host argument must be a scalar character", { 10 | expect_error(fetch_protocol(host = c("localhost", "localhost"))) 11 | expect_error(fetch_protocol(host = 127.1)) 12 | }) 13 | 14 | test_that("fetch_protocol() port argument must be a numeric or character scalar", { 15 | expect_error(fetch_protocol(port = TRUE)) 16 | expect_error(fetch_protocol(port = c(9222, 9223))) 17 | }) 18 | 19 | setup_chrome_test() 20 | 21 | # fetch_version() tests 22 | test_that("fetch_version() returns a list", { 23 | expect_is(fetch_version(), "list") 24 | }) 25 | 26 | # combined tests 27 | initial_target <- list_targets()[[1]] 28 | 29 | test_that("list_targets() returns a list of length 1 when Chrome opens", { 30 | expect_is(list_targets(), "list") 31 | expect_identical(length(list_targets()), 1L) 32 | }) 33 | 34 | test_that("new_tab deals with wrong url arg", { 35 | expect_error(new_tab(url = 3)) 36 | expect_error(new_tab(url = c("localhost", "www.google.com"))) 37 | }) 38 | 39 | new_target <- new_tab(url = "https://www.r-project.org/") 40 | 41 | test_that("new_tab can open a with a new url", { 42 | expect_identical(new_target$url, "https://www.r-project.org/") 43 | expect_identical(new_target$type, "page") 44 | }) 45 | 46 | test_that("new_tab() returns a list and increment the length of list_targets()", { 47 | expect_is(new_target, "list") 48 | expect_identical(length(list_targets()), 2L) 49 | }) 50 | 51 | test_that("activate_target() returns TRUE if the target exists, FALSE otherwise", { 52 | expect_identical(activate_target(target_id = initial_target$id), TRUE) 53 | expect_identical(activate_target(target_id = "1234"), FALSE) 54 | }) 55 | 56 | test_that("close_target() returns TRUE if the target exists and reduce the length of list_targets(), FALSE otherwise.", { 57 | expect_identical(close_target(target_id = new_target$id), TRUE) 58 | expect_identical(close_target(target_id = "1234"), FALSE) 59 | expect_identical(length(list_targets), 1L) 60 | }) 61 | 62 | test_that("fetch remote protocol works and returns a list", { 63 | expect_is(fetch_protocol(), "list") 64 | }) 65 | 66 | test_that("inspect_target() throws an error for a wrong target_id", { 67 | expect_error(inspect_target(target_id = new_target$id)) 68 | }) 69 | 70 | test_that("inspect_target() returns NULL for a correct target_id", { 71 | skip_if_not(interactive()) 72 | expect_identical(inspect_target(target_id = initial_target$id), NULL) 73 | }) 74 | 75 | test_that("inspect_target() returns NULL with a warning() in a non interactive session", { 76 | skip_if(interactive()) 77 | expect_warning(res <- inspect_target(target_id = initial_target$id)) 78 | expect_identical(res, NULL) 79 | }) 80 | 81 | test_that("is_localhost", { 82 | expect_true(is_localhost("http://localhost:9222")) 83 | expect_true(is_localhost("http://127.0.0.1:9222")) 84 | expect_false(is_localhost("https://github.com/RLesur/crrri")) 85 | expect_false(is_localhost("")) 86 | }) 87 | 88 | test_that("browse_url use default function if no option set", { 89 | old_opt <- options(viewer = NULL) 90 | url <- "http://localhost:9222" 91 | expect_identical( 92 | with_mock( 93 | browseURL = identity, 94 | expect_identical(browse_url(url), url) 95 | ), 96 | url) 97 | options(viewer = old_opt) 98 | }) 99 | 100 | test_that("browse_url use default function if no localhost", { 101 | url <- "https://github.com/RLesur/crrri" 102 | expect_identical( 103 | with_mock( 104 | browseURL = identity, 105 | expect_identical(browse_url(url), url) 106 | ), 107 | url) 108 | }) 109 | 110 | -------------------------------------------------------------------------------- /man/CDPRemote.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CDPRemote.R 3 | \name{CDPRemote} 4 | \alias{CDPRemote} 5 | \title{Declare a remote application implementing the Chrome Debugging Protocol} 6 | \description{ 7 | This class aims to declare an application implementing the Chrome Debugging 8 | Protocol. It possesses methods to manage connections. 9 | } 10 | \section{Usage}{ 11 | \preformatted{remote <- CDPRemote$new(host = "localhost", debug_port = 9222, secure = FALSE, 12 | local = FALSE, retry_delay = 0.2, max_attempts = 15L) 13 | 14 | remote$connect(callback = NULL) 15 | remote$listConnections() 16 | remote$closeConnections(callback = NULL) 17 | remote$version() 18 | remote$user_agent 19 | } 20 | } 21 | 22 | \section{Arguments}{ 23 | 24 | \itemize{ 25 | \item \code{remote}: an object representing a remote application implementing the 26 | Chrome Debugging Protocol. 27 | \item \code{host}: Character scalar, the host name of the application. 28 | \item \code{debug_port}: Integer scalar, the remote debugging port. 29 | \item \code{secure}: Logical scalar, indicating whether the https/wss protocols 30 | shall be used for connecting to the remote application. 31 | \item \code{local}: Logical scalar, indicating whether the local version of the 32 | protocol (embedded in \code{crrri}) must be used or the protocol must be 33 | fetched \emph{remotely}. 34 | \item \code{retry_delay}: Number, delay in seconds between two successive tries to 35 | connect to the remote application. 36 | \item \code{max_attempts}: Integer scalar, number of tries to connect to headless 37 | Chromium/Chrome. 38 | \item \code{callback}: Function with one argument. 39 | } 40 | } 41 | 42 | \section{Details}{ 43 | 44 | \verb{$new()} declares a new remote application. 45 | 46 | \verb{$connect(callback = NULL)} connects the R session to the remote application. 47 | The returned value depends on the value of the \code{callback} argument. When 48 | \code{callback} is a function, the returned value is a connection object. When 49 | \code{callback} is \code{NULL} the returned value is a promise which fulfills once R 50 | is connected to the remote application. Once fulfilled, the value of this 51 | promise is the connection object. 52 | 53 | \verb{$listConnections()} returns a list of the connection objects succesfully 54 | created using the \verb{$connect()} method. 55 | 56 | \verb{$closeConnections(callback = NULL)} closes all the connections created using 57 | the \verb{$connect()} method. If \code{callback} is \code{NULL}, it returns a promise which 58 | fulfills when all the connections are closed: once fulfilled, its value is the 59 | remote object. 60 | If \code{callback} is not \code{NULL}, it returns the remote object. In this case, 61 | \code{callback} is called when all the connections are closed and the remote object is 62 | passed to this function as the argument. 63 | 64 | \verb{$version()} executes the DevTools \code{Version} method. It returns a list of 65 | informations available at \verb{http://:/json/version}. 66 | 67 | \verb{$user_agent} returns a character scalar with the User Agent of the 68 | remote application. 69 | 70 | \verb{$listTargets()} returns a list with information about targets (or tabs). 71 | } 72 | 73 | \examples{ 74 | \dontrun{ 75 | # Assuming that an application is already running at http://localhost:9222 76 | # For instance, you can execute: 77 | # chrome <- Chrome$new() 78 | 79 | remote <- CDPRemote$new() 80 | 81 | remote$connect() \%...>\% (function(client) { 82 | Page <- client$Page 83 | Runtime <- client$Runtime 84 | 85 | Page$enable() \%...>\% { 86 | Page$navigate(url = 'http://r-project.org') 87 | } \%...>\% { 88 | Page$loadEventFired() 89 | } \%...>\% { 90 | Runtime$evaluate( 91 | expression = 'document.documentElement.outerHTML' 92 | ) 93 | } \%...>\% (function(result) { 94 | cat(result$result$value, "\n") 95 | }) \%...!\% { 96 | cat("Error:", .$message, "\n") 97 | } \%>\% 98 | promises::finally(~ client$disconnect()) 99 | }) \%...!\% { 100 | cat("Error:", .$message, "\n") 101 | } 102 | } 103 | 104 | } 105 | -------------------------------------------------------------------------------- /tests/testthat/test-EventEmitter.R: -------------------------------------------------------------------------------- 1 | context("test-EventEmitter") 2 | 3 | test_that("register with on() and emit an event", { 4 | myEmitter <- EventEmitter$new() 5 | myEmitter$on("event", 6 | function() { 7 | message("an event occured!") 8 | } 9 | ) 10 | expect_message(myEmitter$emit("event"), "an event occured!") 11 | }) 12 | 13 | test_that("addListener works too", { 14 | myEmitter <- EventEmitter$new() 15 | myEmitter$addListener("event", 16 | function() { 17 | message("an event occured!") 18 | } 19 | ) 20 | expect_message(myEmitter$emit("event"), "an event occured!") 21 | }) 22 | 23 | test_that("register with on() and emit an events twice", { 24 | myEmitter <- EventEmitter$new() 25 | myEmitter$on("event", 26 | function() { 27 | message("an event occured!") 28 | } 29 | ) 30 | expect_message(myEmitter$emit("event"), "an event occured!") 31 | expect_message(myEmitter$emit("event"), "an event occured!") 32 | }) 33 | 34 | test_that("register with once() and emit an event only once", { 35 | myEmitter <- EventEmitter$new() 36 | myEmitter$once("event", 37 | function() { 38 | message("an event occured!") 39 | } 40 | ) 41 | expect_message(myEmitter$emit("event"), "an event occured!") 42 | expect_silent(myEmitter$emit("event")) 43 | myEmitter$once("a.listener", rlang::as_function(~ cat(.x))) 44 | expect_output(myEmitter$emit("a.listener", "A"), "A") 45 | expect_silent(myEmitter$emit("a.listener", "B")) 46 | }) 47 | 48 | test_that("An error in a listener will throw an error in R", { 49 | myEmitter <- EventEmitter$new() 50 | myEmitter$on("event", function(...) stop("An error in a listener")) 51 | expect_error(myEmitter$emit("event"), regexp = "An error in a listener") 52 | }) 53 | 54 | test_that("An error event catches error", { 55 | myEmitter <- EventEmitter$new() 56 | myEmitter$on("event", function(...) stop("An error in a listener")) 57 | myEmitter$on("error", function(e) message(conditionMessage(e))) 58 | expect_message(myEmitter$emit("event"), regexp = "^An error in a listener\n$") 59 | }) 60 | 61 | 62 | test_that("A newListener is emitted before registration", { 63 | # As in the node.js class, a "newListener" event is emitted 64 | # before each new listener registration. 65 | # The "newListener" event passes two arguments to its listener(s): 66 | # `eventName` and `listener`. 67 | myEmitter <- EventEmitter$new() 68 | # Use once here to avoid infinite recursion: 69 | myEmitter$once("newListener", function(eventName, listener) { 70 | if(eventName == "event") { 71 | myEmitter$on("event", function(...) cat("B")) 72 | } 73 | }) 74 | myEmitter$on("event", function(...) cat("A")) 75 | myEmitter$emit("event") # BA 76 | expect_output(myEmitter$emit("event"), "^BA$") 77 | # The listener attached to the "newListener" event has been 78 | # unregistered and is no more called: 79 | myEmitter$on("event", function(...) cat("C")) 80 | expect_output(myEmitter$emit("event"), "^BAC$") 81 | }) 82 | 83 | test_that("countListner get the number of listener", { 84 | myEmitter <- EventEmitter$new() 85 | myEmitter$on("event", function(...) cat("A")) 86 | myEmitter$on("event", function(...) cat("B")) 87 | myEmitter$on("event", function(...) cat("C")) 88 | expect_identical(myEmitter$listenerCount("event"), 3L) 89 | }) 90 | 91 | test_that("countListner get the number of listener", { 92 | myEmitter <- EventEmitter$new() 93 | myEmitter$on("event", function(...) cat("A")) 94 | expect_identical(myEmitter$eventNames(), c("event")) 95 | myEmitter$on("anotherevent", function(...) cat("A")) 96 | expect_identical(myEmitter$eventNames(), c("event", "anotherevent")) 97 | }) 98 | 99 | test_that("listeners returns registered listener", { 100 | myEmitter <- EventEmitter$new() 101 | myEmitter$on("event", function(...) cat("A")) 102 | expect_identical(myEmitter$listeners("event")[[1]], function(...) cat("A")) 103 | }) 104 | 105 | test_that("rawListeners returns once registered listener with a special attribute", { 106 | myEmitter <- EventEmitter$new() 107 | myEmitter$once("event", function(...) cat("A")) 108 | expect_true(rlang::inherits_all( 109 | myEmitter$rawListeners("event")[[1]], 110 | c("crrri_callback_wrapper", "once_function", "function")) 111 | ) 112 | expect_s3_class(myEmitter$rawListeners("event")[[1]], "crrri_callback_wrapper") 113 | expect_identical(dewrap(myEmitter$rawListeners("event")[[1]]), function(...) cat("A")) 114 | }) 115 | 116 | test_that("rawListeners returns register listeners", { 117 | myEmitter <- EventEmitter$new() 118 | expect_identical(myEmitter$rawListeners("event"), list()) 119 | myEmitter$on("event", function(...) cat("A")) 120 | expect_identical(myEmitter$rawListeners("event")[[1]], function(...) cat("A")) 121 | }) 122 | 123 | test_that("Queue works as expected", { 124 | Qu <- Queue$new() 125 | Qu$append("a") 126 | expect_identical(Qu$count(), 1L) 127 | expect_identical(Qu$get(), list("a")) 128 | Qu$append("b") 129 | expect_identical(Qu$get(), list("a", "b")) 130 | rm_c <- Qu$prepend("c") 131 | expect_identical(Qu$get(), list("c", "a", "b")) 132 | rm_c() 133 | expect_identical(Qu$get(), list("a", "b")) 134 | }) 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | -------------------------------------------------------------------------------- /R/CDProtocol.R: -------------------------------------------------------------------------------- 1 | #' @include http_methods.R 2 | NULL 3 | 4 | CDProtocol <- R6::R6Class( 5 | "CDProtocol", 6 | public = list( 7 | initialize = function(host = "localhost", port = 9222, secure = FALSE, local = TRUE) { 8 | protocol <- fetch_protocol(host = host, port = port, secure = secure, local = local) 9 | protocol <- add_names_to_protocol(protocol) 10 | protocol <- rlist2env(protocol) 11 | private$.protocol <- protocol 12 | }, 13 | domain_description = function(domain) { 14 | desc <- rlang::env_get(env = private$.protocol$domains, nm = domain)$description 15 | if(is.null(desc)) { 16 | desc <- "" 17 | } 18 | desc 19 | }, 20 | is_domain_experimental = function(domain) { 21 | isTRUE(private$.protocol$domains[[domain]]$experimental) 22 | }, 23 | list_commands = function(domain) { 24 | private$.list_objects(domain, "commands") 25 | }, 26 | get_formals_for_command = function(domain, command) { 27 | params_env <- private$.protocol$domains[[domain]]$commands[[command]]$parameters 28 | if(is.null(params_env)) { 29 | params_names <- character(0) 30 | } else { 31 | params_names <- purrr::set_names(ls(params_env)) 32 | } 33 | # since we will add a callback argument, check that callback is not already used: 34 | stopifnot(!("callback" %in% params_names)) 35 | params_optional <- purrr::map_lgl(params_names, ~ isTRUE(params_env[[.x]]$optional)) 36 | if(length(params_optional) > 0) { 37 | params_optional <- sort(params_optional) # get the required params first 38 | } 39 | params_optional <- c(params_optional, callback = TRUE) 40 | # build the pairlist string: 41 | text <- paste0( 42 | "alist(", 43 | paste(names(params_optional), ifelse(params_optional, "NULL", ""), sep = " = ", collapse = ", "), 44 | ")" 45 | ) 46 | # return the pairlist: 47 | eval(parse(text = text)) 48 | }, 49 | list_events = function(domain) { 50 | private$.list_objects(domain, "events") 51 | }, 52 | get_formals_for_event = function(domain, event) { 53 | params_env <- private$.protocol$domains[[domain]]$events[[event]]$parameters 54 | if(is.null(params_env)) { 55 | params_names <- character(0) 56 | } else { 57 | params_names <- ls(params_env) 58 | } 59 | # since we will add a callback argument, check that callback is not already used: 60 | stopifnot(!("callback" %in% params_names)) 61 | # here is the main difference with get_formals_for_command: 62 | # in an event listener, all the parameters are optional 63 | # we can directly add the callback argument... 64 | params_names <- c(params_names, "callback") 65 | # ... and return the list 66 | res <- vector("list", length(params_names)) 67 | names(res) <- params_names 68 | res 69 | }, 70 | list_types = function(domain) { 71 | private$.list_objects(domain, "types") 72 | } 73 | ), 74 | active = list( 75 | domains = function() { 76 | ls(private$.protocol$domains) 77 | } 78 | ), 79 | private = list( 80 | .protocol = "environment", 81 | .list_objects = function(domain, cl) { 82 | specs <- rlang::env_get(env = private$.protocol$domains, nm = domain)[[cl]] 83 | if(is.null(specs)) return(list()) 84 | obj_names <- ls(specs) 85 | l <- as.list(paste(domain, obj_names, sep = ".")) 86 | names(l) <- obj_names 87 | l 88 | } 89 | ) 90 | ) 91 | 92 | rlist2env <- function(.l) { 93 | if (!is.list(.l)) return(.l) 94 | list2env(purrr::map(.l, rlist2env), parent = emptyenv()) 95 | } 96 | 97 | add_names_to_protocol <- function(protocol) { 98 | protocol$domains <- purrr::map(protocol$domains, add_names_to_domain) 99 | names(protocol$domains) <- purrr::map_chr(protocol$domains, "domain") 100 | protocol 101 | } 102 | 103 | add_names_to_domain <- function(domain) { 104 | if(!is.null(domain$dependencies)) { 105 | domain$dependencies <- unlist(domain$dependencies) 106 | } 107 | if(!is.null(domain$types)) { 108 | domain$types <- purrr::map(domain$types, add_names_to_type) 109 | names(domain$types) <- purrr::map_chr(domain$types, "id") 110 | } 111 | if(!is.null(domain$commands)) { 112 | domain$commands <- purrr::map(domain$commands, add_names_to_method) 113 | names(domain$commands) <- purrr::map_chr(domain$commands, "name") 114 | } 115 | if(!is.null(domain$events)) { 116 | domain$events <- purrr::map(domain$events, add_names_to_method) 117 | names(domain$events) <- purrr::map_chr(domain$events, "name") 118 | } 119 | domain 120 | } 121 | 122 | add_names_to_type <- function(type) { 123 | if(!is.null(type$properties)) { 124 | names(type$properties) <- purrr::map_chr(type$properties, "name") 125 | } 126 | type 127 | } 128 | 129 | add_names_to_method <- function(method) { 130 | if(!is.null(method$parameters)) { 131 | names(method$parameters) <- purrr::map_chr(method$parameters, "name") 132 | } 133 | if(!is.null(method$returns)) { 134 | names(method$returns) <- purrr::map_chr(method$returns, "name") 135 | } 136 | method 137 | } 138 | 139 | renv2list <- function(e, discard = NULL) { 140 | if(!rlang::is_environment(e)) return(e) 141 | names <- purrr::discard(ls(e), ~ .x %in% discard) 142 | names <- rlang::set_names(names) 143 | purrr::map(names, ~ renv2list(e[[.x]], discard)) 144 | } 145 | -------------------------------------------------------------------------------- /man/Chrome.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Chrome.R 3 | \name{Chrome} 4 | \alias{Chrome} 5 | \title{Launch Chromium or Chrome} 6 | \description{ 7 | This class aims to launch Chromium or Chrome in headless mode. It possesses 8 | methods to manage connections to headless Chromium/Chrome using the 9 | Chrome Debugging Protocol. 10 | } 11 | \section{Usage}{ 12 | \preformatted{remote <- Chrome$new(bin = NULL, debug_port = 9222L, 13 | local = FALSE, extra_args = NULL, headless = TRUE, 14 | retry_delay = 0.2, max_attempts = 15L) 15 | 16 | remote$connect(callback = NULL) 17 | remote$listConnections() 18 | remote$closeConnections(callback = NULL) 19 | remote$version() 20 | remote$user_agent 21 | 22 | remote$close(async = FALSE) 23 | remote$view() 24 | remote$is_alive() 25 | } 26 | } 27 | 28 | \section{Arguments}{ 29 | 30 | \itemize{ 31 | \item \code{remote}: \code{Chrome} object representing a remote instance of headless 32 | Chromium/Chrome. 33 | \item \code{bin}: Character scalar, the path to Chromium or Chrome executable. 34 | If not provided, \code{crrri} will try to find the chrome binary itself using 35 | \code{find_chrome_binary()}. You can set a path in \code{HEADLESS_CHROME} environment 36 | variable to indicate where it is located. 37 | \item \code{debug_port}: Integer scalar, the Chromium/Chrome remote debugging port. 38 | Note that headless Chromium/Chrome will be available at 39 | \verb{http://localhost:}. 40 | \item \code{local}: Logical scalar, indicating whether the local version of the 41 | protocol (embedded in \code{crrri}) must be used or the protocol must be 42 | fetched \emph{remotely}. 43 | \item \code{extra_args}: Character vector, extra command line arguments passed to 44 | Chromium/Chrome. You can know more about command line flags (or switches) 45 | from \href{https://www.chromium.org/developers/how-tos/run-chromium-with-flags}{chromium developers} 46 | \item \code{headless}: Logical scalar, indicating whether Chromium/Chrome is launched 47 | in headless mode. 48 | \item \code{retry_delay}: Number, delay in seconds between two successive tries to 49 | connect to headless Chromium/Chrome. 50 | \item \code{max_attempts}: Integer scalar, number of tries to connect to headless 51 | Chromium/Chrome. 52 | \item \code{callback}: Function with one argument. 53 | \item \code{async}: Does the function return a promise? 54 | } 55 | } 56 | 57 | \section{Details}{ 58 | 59 | \verb{$new()} opens a new headless Chromium/Chrome. You can deactivate verbose 60 | from chrome process launching byt setting option \code{crrri.verbose} to FALSE. 61 | 62 | \verb{$connect(callback = NULL)} connects the R session to the remote instance of 63 | headless Chromium/Chrome. The returned value depends on the value of the 64 | \code{callback} argument. When \code{callback} is a function, the returned value is a 65 | connection object. When \code{callback} is \code{NULL} the returned value is a promise 66 | which fulfills once R is connected to the remote instance of Chromium/Chrome. 67 | Once fulfilled, the value of this promise is the connection object. 68 | 69 | \verb{$listConnections()} returns a list of the connection objects succesfully 70 | created using the \verb{$connect()} method. 71 | 72 | \verb{$closeConnections(callback = NULL)} closes all the connections created using the 73 | \verb{$connect()} method. If \code{callback} is \code{NULL}, it returns a promise which 74 | fulfills when all the connections are closed: once fulfilled, its value is the 75 | remote object. 76 | If \code{callback} is not \code{NULL}, it returns the remote object. In this case, 77 | \code{callback} is called when all the connections are closed and the remote object is 78 | passed to this function as the argument. 79 | 80 | \verb{$version()} executes the DevTools \code{Version} method. It returns a list of 81 | informations available at \verb{http://localhost:/json/version}. 82 | 83 | \verb{$user_agent} returns a character scalar with the User Agent of the 84 | headless Chromium/Chrome. 85 | 86 | \verb{$close(async = FALSE)} closes the remote instance of headless 87 | Chromium/Chrome. If \code{async} is \code{FALSE} this method returns the \code{remote} 88 | object invisibly. Is \code{async} is \code{TRUE}, a promise is returned. This promise 89 | fulfills when Chromium/Chrome is closed. Once fulfilled, its value is the 90 | \code{remote} object. 91 | 92 | \verb{$view()} opens a visible Chromium/Chrome browser at 93 | \verb{http://localhost:}. This is useful to 'see' the headless 94 | Chromium/Chrome instance. Returns the process of the visible browser. 95 | 96 | \verb{$is_alive()} checks if the remote instance is alive. Returns a logical 97 | scalar. 98 | 99 | \verb{$listTargets()} returns a list with information about tabs. 100 | } 101 | 102 | \examples{ 103 | \dontrun{ 104 | 105 | remote <- Chrome$new() 106 | 107 | remote$connect() \%...>\% (function(client) { 108 | Page <- client$Page 109 | Runtime <- client$Runtime 110 | 111 | Page$enable() \%...>\% { 112 | Page$navigate(url = 'http://r-project.org') 113 | } \%...>\% { 114 | Page$loadEventFired() 115 | } \%...>\% { 116 | Runtime$evaluate( 117 | expression = 'document.documentElement.outerHTML' 118 | ) 119 | } \%...>\% (function(result) { 120 | cat(result$result$value, "\n") 121 | }) 122 | }) \%...!\% { 123 | cat("Error:", .$message, "\n") 124 | } \%>\% 125 | promises::finally(~ remote$close()) 126 | } 127 | 128 | } 129 | -------------------------------------------------------------------------------- /R/domain.R: -------------------------------------------------------------------------------- 1 | #' @include reexport-promises.R utils.R 2 | NULL 3 | 4 | domain <- function(client, domain_name) { 5 | protocol <- client$.__protocol__ 6 | members_names <- names(c( 7 | protocol$list_commands(domain_name), 8 | protocol$list_events(domain_name), 9 | protocol$list_types(domain_name) 10 | )) 11 | 12 | CustomDomain <- R6::R6Class( 13 | domain_name, 14 | inherit = Domain, 15 | public = list( 16 | initialize = function(client, domain) { 17 | super$initialize(client, domain) 18 | protocol <- client$.__protocol__ 19 | commands <- protocol$list_commands(domain) 20 | events <- protocol$list_events(domain) 21 | types <- protocol$list_types(domain) 22 | purrr::iwalk(commands, function(command, name) { 23 | self[[name]] <- private$.build_command(command, name) 24 | }) 25 | purrr::iwalk(events, function(event, name) { 26 | self[[name]] <- private$.build_event_listener(event, name) 27 | }) 28 | } 29 | ) 30 | ) 31 | 32 | purrr::walk(members_names, ~ CustomDomain$set("public", .x, NULL)) 33 | CustomDomain$new(client, domain_name) 34 | } 35 | 36 | Domain <- R6::R6Class( 37 | "Domain", 38 | public = list( 39 | initialize = function(client, domain) { 40 | self$.__client__ <- client 41 | private$.domain_name <- domain 42 | }, 43 | print = function() { 44 | utils::browseURL(paste0("https://chromedevtools.github.io/devtools-protocol/tot/", private$.domain_name)) 45 | invisible(self) 46 | }, 47 | .__client__ = NULL 48 | ), 49 | private = list( 50 | .domain_name = NULL, 51 | .build_command = function(method_to_be_sent, name) { 52 | # environment of the current fonction to get 53 | # `method_to_be_sent` when needed 54 | fn_env <- rlang::current_env() 55 | 56 | fun <- function() { 57 | params_to_be_sent <- 58 | rlang::fn_fmls_names() %>% # pick the fun arguments 59 | utils::head(-1) %>% # remove the callback argument 60 | rlang::env_get_list(nms = ., inherit = TRUE) %>% # retrieve values 61 | purrr::discard(~ purrr::is_null(.x)) # remove arguments identical to NULL 62 | 63 | if(!is.null(callback)) { 64 | callback <- rlang::as_function(callback) 65 | } 66 | # since the function parameters are not controlled, 67 | # there might be some conflicts between CDP parameters and `method_to_be_sent` 68 | # Therefore, we use env_get() to retrieve the correct `method_to_be_sent` 69 | self$.__client__$send( 70 | rlang::env_get(env = fn_env, nm = "method_to_be_sent"), 71 | params = params_to_be_sent, 72 | onresponse = callback 73 | ) 74 | } 75 | formals(fun) <- self$.__client__$.__protocol__$get_formals_for_command(private$.domain_name, name) 76 | fun 77 | }, 78 | .build_event_listener = function(event_to_listen, name) { 79 | fun <- function() { 80 | if(!is.null(callback)) { 81 | callback <- rlang::as_function(callback) 82 | } 83 | predicates_list <- 84 | rlang::fn_fmls_names() %>% # pick the fun arguments 85 | utils::head(-1) %>% # remove the callback argument 86 | rlang::env_get_list(nms = ., inherit = TRUE) %>% # retrieve arguments values 87 | purrr::discard(~ purrr::is_null(.x)) # remove arguments identical to NULL 88 | 89 | # if there is no predicate function in the list, return early 90 | if(length(predicates_list) == 0L) { 91 | return(self$.__client__$on(event_to_listen, callback = callback)) 92 | } 93 | 94 | caller_env <- rlang::caller_env() 95 | predicate_fun <- 96 | predicates_list %>% 97 | purrr::map(as_predicate, env = caller_env) %>% # transform the arguments to predicate 98 | combine_predicates() 99 | 100 | # if callback is NULL, we must return a promise 101 | if(is.null(callback)) { 102 | return(promises::promise(function(resolve, reject) { 103 | rm_listener <- NULL 104 | rm_listener <- self$.__client__$on(event_to_listen, callback = function(result) { 105 | if(predicate_fun(result)) { 106 | rm_listener() 107 | resolve(result) 108 | } 109 | }) 110 | })) 111 | } 112 | 113 | # Now, we know that we have to use a listener and return the function 114 | # that removes this listener. We also have to ensure that this function 115 | # sends back the original callback function 116 | callback <- rlang::as_function(callback) 117 | rm_listener <- NULL 118 | out <- function() { 119 | rm_listener() 120 | invisible(callback) 121 | } 122 | callback_wrapper <- function(result) { 123 | if(predicate_fun(result)) { 124 | callback(result) 125 | } 126 | rm_listener() 127 | } 128 | callback_wrapper <- new_callback_wrapper(callback_wrapper, callback) 129 | rm_listener <- self$.__client__$on(event_to_listen, callback = callback_wrapper) 130 | 131 | # Now, return the function that removes the listener and returns the original callback 132 | invisible(out) 133 | } 134 | formals(fun) <- self$.__client__$.__protocol__$get_formals_for_event(private$.domain_name, name) 135 | fun 136 | } 137 | ) 138 | ) 139 | 140 | -------------------------------------------------------------------------------- /vignettes/intro.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "How to use crrri?" 3 | subtitle: "Some introductive examples" 4 | author: "Christophe Dervieux" 5 | date: "`r Sys.Date()`" 6 | output: rmarkdown::html_vignette 7 | vignette: > 8 | %\VignetteIndexEntry{How to use crrri?} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | %\VignetteEncoding{UTF-8} 11 | --- 12 | 13 | ```{r setup, include = FALSE} 14 | knitr::opts_chunk$set( 15 | collapse = TRUE, 16 | eval = FALSE, 17 | comment = "#>" 18 | ) 19 | Sys.unsetenv("DEBUGME") 20 | ``` 21 | 22 | The `crrri` package provides a _Chrome Remote Interface_ for R. It is inspired by the node.js module [`chrome-remote-interface`](https://www.npmjs.com/package/chrome-remote-interface). 23 | 24 | This vignette aims to show several examples of usage for `crrri`. 25 | 26 | All the examples come from the [`chrome-remote-interface`](https://www.npmjs.com/package/chrome-remote-interface) or [`puppeteer`](https://www.npmjs.com/package/puppeteer) documentations. This vignette shows how to reproduce those using `crrri`. 27 | 28 | # Setup 29 | 30 | It is better to set up beforehand the `HEADLESS_CHROME` environment variable to a Chromium/Chrome binary on our system that `crrri` will use. If you do not, you can provide the path to a Chromium/Chrome binary in `Chrome$new()` or let the package guess using its `find_chrome_binary()`. 31 | 32 | The default behavior of `crrri` is equivalent to setting the environment variable like this 33 | 34 | ```{r, eval=FALSE} 35 | Sys.setenv(HEADLESS_CHROME = crrri::find_chrome_binary()) 36 | ``` 37 | 38 | We need to load `crrri` and also `promises` to have the tools to deals with 39 | _promises_ that `crrri` is based on. 40 | 41 | ```{r} 42 | library(crrri) 43 | library(promises) 44 | ``` 45 | 46 | # Example 1: Take a screenshot 47 | 48 | This first example is inspired from this 49 | [post](https://jonathanmh.com/taking-full-page-screenshots-headless-chrome/) that uses the `chrome-remote-interface` node.js package. 50 | 51 | The first step is to launch Chromium/Chrome in headless mode: 52 | 53 | ```{r launch-chrome, results='hide'} 54 | chrome <- Chrome$new() 55 | ``` 56 | 57 | Then connect R to headless Chromium/Chrome with the `connect()` method. Since the connection process is not immediate, the `connect()` method returns a promise that is fulfilled when R is connected to Chrome. The value of this promise is the connection object. 58 | 59 | ```{r connect} 60 | client <- chrome$connect() 61 | ``` 62 | 63 | You need to write a function whose first parameter will receive the `client` connection object. 64 | ```{r screenshot-fn} 65 | screenshot_file <- tempfile(fileext = ".png") 66 | 67 | screenshot <- function(client) { 68 | # some constants 69 | targetUrl <- "https://cran.rstudio.com" 70 | viewport <- c(1440, 900) 71 | screenshotDelay <- 2 # seconds 72 | 73 | # extract the domain you need 74 | Page <- client$Page 75 | Emulation <- client$Emulation 76 | 77 | # enable events for the Page, DOM and Network domains 78 | Page$enable() %...>% { 79 | # modify the viewport settings 80 | Emulation$setDeviceMetricsOverride( 81 | width = viewport[1], 82 | height = viewport[2], 83 | deviceScaleFactor = 0, 84 | mobile = FALSE, 85 | dontSetVisibleSize = FALSE 86 | ) 87 | } %...>% { 88 | # go to url 89 | Page$navigate(targetUrl) 90 | # wait the page is loaded 91 | Page$loadEventFired() 92 | } %>% 93 | # add a delay 94 | wait(delay = screenshotDelay) %...>% { 95 | # capture screenshot 96 | Page$captureScreenshot(format = "png", fromSurface = TRUE) 97 | } %...>% { 98 | .$data %>% 99 | jsonlite::base64_dec() %>% 100 | writeBin(screenshot_file) 101 | } %>% 102 | # close headless chrome (client connections are safely closed) 103 | finally( 104 | ~ client$disconnect() 105 | ) %...!% { 106 | cat("Error:", .$message, "\n") 107 | } 108 | } 109 | ``` 110 | 111 | Therefore, you can take a screenshot by executing this `screenshot()` function: 112 | 113 | ```{r chrome-screenshot, eval=FALSE} 114 | client %...>% screenshot() 115 | ``` 116 | 117 | ```{r, include=FALSE} 118 | # since screenshot returns an invisible promise, we have to force R to hold 119 | hold(client %...>% screenshot()) 120 | ``` 121 | 122 | The screenshot is written to disk and looks like this: 123 | ```{r, eval=TRUE, echo=FALSE, results='asis', out.width=400} 124 | knitr::include_graphics("example1-screenshot.png") 125 | ``` 126 | 127 | # Example 2: Dump HTML after page loaded 128 | 129 | This example is inspired from this [JavaScript script](https://github.com/cyrus-and/chrome-remote-interface/wiki/Dump-HTML-after-page-load) from the `chrome-remote-interface` wiki that dumps the DOM. 130 | 131 | ```{r dump-dom-fun} 132 | html_file <- tempfile(fileext = ".html") 133 | 134 | client <- chrome$connect() 135 | 136 | dump_DOM <- function(client) { 137 | Network <- client$Network 138 | Page <- client$Page 139 | Runtime <- client$Runtime 140 | Network$enable() %...>% 141 | { Page$enable() } %...>% 142 | { Network$setCacheDisabled(cacheDisabled = TRUE) } %...>% 143 | { Page$navigate(url = "https://github.com") } %...>% 144 | { Page$loadEventFired() } %...>% { 145 | Runtime$evaluate( 146 | expression = 'document.documentElement.outerHTML' 147 | ) 148 | } %...>% { 149 | writeLines(c(.$result$value, "\n"), con = html_file) 150 | } %>% 151 | finally( 152 | ~ client$disconnect() 153 | ) %...!% { 154 | cat("Error:", .$message, "\n") 155 | } 156 | } 157 | ``` 158 | 159 | Execute the task: 160 | 161 | ```{r, eval=FALSE} 162 | client %...>% dump_DOM() 163 | ``` 164 | 165 | ```{r, include=FALSE} 166 | # since dump_dom is an invisible promise, we have to force R to hold 167 | hold(client %...>% dump_DOM()) 168 | chrome$close() 169 | ``` 170 | 171 | Here is the first 20 lines of what we get in `html_file`: 172 | 173 | ```{r, eval=TRUE, echo=FALSE, results='asis'} 174 | cat(paste0( 175 | c("```html", readLines("dumpDOM.html", n = 20), "```"), 176 | collapse = "\n" 177 | )) 178 | ``` 179 | 180 | This could be useful to parse HTML with `rvest` after a page is loaded. 181 | -------------------------------------------------------------------------------- /man/EventEmitter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/EventEmitter.R 3 | \name{EventEmitter} 4 | \alias{EventEmitter} 5 | \title{R6 class to emit some event} 6 | \description{ 7 | This is a general purpose class to build on. It is inspired by the node.js EventEmitter class. 8 | See \url{https://nodejs.org/api/events.html}. 9 | } 10 | \examples{ 11 | myEmitter <- EventEmitter$new() 12 | myEmitter$on("event", 13 | function() { 14 | message("an event occured!") 15 | } 16 | ) 17 | myEmitter$emit("event") 18 | # The listener is still called when "event" fires: 19 | myEmitter$emit("event") 20 | # A listener can be registered once: 21 | myEmitter$once("event", 22 | function() { 23 | message("this listener is called only once") 24 | } 25 | ) 26 | # This new listener will be removed when called. 27 | myEmitter$emit("event") 28 | # There is now only one listener: 29 | myEmitter$emit("event") 30 | 31 | # An error in a listener will throw an error in R. 32 | myEmitter$on("event", function(...) stop("An error in a listener")) 33 | # Throw an error: 34 | \dontrun{ 35 | myEmitter$emit("event")} 36 | 37 | # You can catch an error with a special "error" event that is 38 | # always emitted when an error occured in a listener: 39 | myEmitter$on("error", function(e) cat(conditionMessage(e))) 40 | myEmitter$emit("event") 41 | 42 | # As in the node.js class, a "newListener" event is emitted 43 | # before each new listener registration. 44 | # The "newListener" event passes two arguments to its listener(s): 45 | # `eventName` and `listener`. 46 | myEmitter <- EventEmitter$new() 47 | # Use once here to avoid infinite recursion: 48 | myEmitter$once("newListener", function(eventName, listener) { 49 | if(eventName == "event") { 50 | myEmitter$on("event", function(...) cat("B")) 51 | } 52 | }) 53 | myEmitter$on("event", function(...) cat("A")) 54 | myEmitter$emit("event") # BA 55 | # The listener attached to the "newListener" event has been 56 | # unregistered and is no more called: 57 | myEmitter$on("event", function(...) cat("C")) 58 | myEmitter$emit("event") # BAC 59 | 60 | # Get the number of listeners for an event: 61 | myEmitter$listenerCount("event") 62 | 63 | # Get the event names which have been registered: 64 | myEmitter$eventNames() 65 | } 66 | \section{Methods}{ 67 | \subsection{Public methods}{ 68 | \itemize{ 69 | \item \href{#method-emit}{\code{EventEmitter$emit()}} 70 | \item \href{#method-on}{\code{EventEmitter$on()}} 71 | \item \href{#method-addListener}{\code{EventEmitter$addListener()}} 72 | \item \href{#method-once}{\code{EventEmitter$once()}} 73 | \item \href{#method-listenerCount}{\code{EventEmitter$listenerCount()}} 74 | \item \href{#method-eventNames}{\code{EventEmitter$eventNames()}} 75 | \item \href{#method-rawListeners}{\code{EventEmitter$rawListeners()}} 76 | \item \href{#method-listeners}{\code{EventEmitter$listeners()}} 77 | \item \href{#method-clone}{\code{EventEmitter$clone()}} 78 | } 79 | } 80 | \if{html}{\out{
}} 81 | \if{html}{\out{}} 82 | \if{latex}{\out{\hypertarget{method-emit}{}}} 83 | \subsection{Method \code{emit()}}{ 84 | \subsection{Usage}{ 85 | \if{html}{\out{
}}\preformatted{EventEmitter$emit(eventName, ...)}\if{html}{\out{
}} 86 | } 87 | 88 | } 89 | \if{html}{\out{
}} 90 | \if{html}{\out{}} 91 | \if{latex}{\out{\hypertarget{method-on}{}}} 92 | \subsection{Method \code{on()}}{ 93 | \subsection{Usage}{ 94 | \if{html}{\out{
}}\preformatted{EventEmitter$on(eventName, listener)}\if{html}{\out{
}} 95 | } 96 | 97 | } 98 | \if{html}{\out{
}} 99 | \if{html}{\out{}} 100 | \if{latex}{\out{\hypertarget{method-addListener}{}}} 101 | \subsection{Method \code{addListener()}}{ 102 | \subsection{Usage}{ 103 | \if{html}{\out{
}}\preformatted{EventEmitter$addListener(eventName, listener)}\if{html}{\out{
}} 104 | } 105 | 106 | } 107 | \if{html}{\out{
}} 108 | \if{html}{\out{}} 109 | \if{latex}{\out{\hypertarget{method-once}{}}} 110 | \subsection{Method \code{once()}}{ 111 | \subsection{Usage}{ 112 | \if{html}{\out{
}}\preformatted{EventEmitter$once(eventName, listener)}\if{html}{\out{
}} 113 | } 114 | 115 | } 116 | \if{html}{\out{
}} 117 | \if{html}{\out{}} 118 | \if{latex}{\out{\hypertarget{method-listenerCount}{}}} 119 | \subsection{Method \code{listenerCount()}}{ 120 | \subsection{Usage}{ 121 | \if{html}{\out{
}}\preformatted{EventEmitter$listenerCount(eventName)}\if{html}{\out{
}} 122 | } 123 | 124 | } 125 | \if{html}{\out{
}} 126 | \if{html}{\out{}} 127 | \if{latex}{\out{\hypertarget{method-eventNames}{}}} 128 | \subsection{Method \code{eventNames()}}{ 129 | \subsection{Usage}{ 130 | \if{html}{\out{
}}\preformatted{EventEmitter$eventNames()}\if{html}{\out{
}} 131 | } 132 | 133 | } 134 | \if{html}{\out{
}} 135 | \if{html}{\out{}} 136 | \if{latex}{\out{\hypertarget{method-rawListeners}{}}} 137 | \subsection{Method \code{rawListeners()}}{ 138 | \subsection{Usage}{ 139 | \if{html}{\out{
}}\preformatted{EventEmitter$rawListeners(eventName)}\if{html}{\out{
}} 140 | } 141 | 142 | } 143 | \if{html}{\out{
}} 144 | \if{html}{\out{}} 145 | \if{latex}{\out{\hypertarget{method-listeners}{}}} 146 | \subsection{Method \code{listeners()}}{ 147 | \subsection{Usage}{ 148 | \if{html}{\out{
}}\preformatted{EventEmitter$listeners(eventName)}\if{html}{\out{
}} 149 | } 150 | 151 | } 152 | \if{html}{\out{
}} 153 | \if{html}{\out{}} 154 | \if{latex}{\out{\hypertarget{method-clone}{}}} 155 | \subsection{Method \code{clone()}}{ 156 | The objects of this class are cloneable with this method. 157 | \subsection{Usage}{ 158 | \if{html}{\out{
}}\preformatted{EventEmitter$clone(deep = FALSE)}\if{html}{\out{
}} 159 | } 160 | 161 | \subsection{Arguments}{ 162 | \if{html}{\out{
}} 163 | \describe{ 164 | \item{\code{deep}}{Whether to make a deep clone.} 165 | } 166 | \if{html}{\out{
}} 167 | } 168 | } 169 | } 170 | -------------------------------------------------------------------------------- /R/http_methods.R: -------------------------------------------------------------------------------- 1 | #' @include utils.R 2 | #' @importFrom assertthat assert_that is.scalar 3 | NULL 4 | 5 | #' Chrome Debugging Protocol HTTP methods 6 | #' 7 | #' When Chromium/Chrome is started in debugging mode, several HTTP endpoints 8 | #' are available. Using these endpoint, one can retrieve information from 9 | #' Chromium/Chrome or send commands, see 10 | #' . 11 | #' 12 | #' @param host Character scalar, the host name of the application. 13 | #' @param port The remote debugging port (a numeric or a character scalar). 14 | #' @param secure A logical indicating whether a secure protocol shall be used. 15 | #' @param local Logical scalar, indicating whether the local version of the 16 | #' protocol (embedded in `crrri`) must be used or the protocol must be 17 | #' fetched _remotely_. 18 | #' @param url URL to open in a new tab. 19 | #' @param target_id Target (or tab) identifier. 20 | #' @return `fetch_version()`, `list_targets()`, `fetch_protocols()` and 21 | #' `new_tab()` return a list. `activate_target()` and `close_target()` returns 22 | #' a logical: `TRUE` is returned when the command succeeds, `FALSE` is 23 | #' returned if a wrong `target_id` is provided. 24 | #' @name http-methods 25 | #' @keywords internal 26 | #' @examples 27 | #' \dontrun{ 28 | #' chrome <- Chrome$new() 29 | #' 30 | #' # fetch information about headless Chrome 31 | #' fetch_version() 32 | #' # fetch the Chromium/Chrome protocol 33 | #' protocol <- fetch_protocol() 34 | #' 35 | #' # get the list of opened tabs 36 | #' list_targets() 37 | #' # open an url in a new tab 38 | #' new_target <- new_tab(url = "http://r-project.org") 39 | #' # the new tab is referenced in the list of opened tabs 40 | #' list_targets() 41 | #' # inspect a target in a web browser 42 | #' if(interactive()) inspect_target(target_id = new_target$id) 43 | #' # close the previous created tab 44 | #' close_target(target_id = new_target$id) 45 | #' 46 | #' chrome$close() 47 | #' } 48 | NULL 49 | 50 | #' @rdname http-methods 51 | #' @export 52 | fetch_version <- function(host = "localhost", port = 9222, secure = FALSE) { 53 | fetch_json(host, port, secure, "version") 54 | } 55 | 56 | #' @rdname http-methods 57 | #' @export 58 | list_targets <- function(host = "localhost", port = 9222, secure = FALSE) { 59 | fetch_json(host, port, secure, "list") 60 | } 61 | 62 | #' @rdname http-methods 63 | #' @export 64 | fetch_protocol <- function(host = "localhost", port = 9222, secure = FALSE, local = FALSE) { 65 | # if the local protocol is fetched, return early 66 | if(isTRUE(local)) { 67 | return(read_local_protocol()) 68 | } 69 | fetch_json(host, port, secure, "protocol") 70 | } 71 | 72 | #' @rdname http-methods 73 | #' @export 74 | new_tab <- function(host = "localhost", port = 9222, secure = FALSE, url = NULL) { 75 | if(!is.null(url)) { 76 | assert_that(is_scalar_character(url)) 77 | } 78 | fetch_json(host, port, secure, "new", url) 79 | } 80 | 81 | #' @rdname http-methods 82 | #' @export 83 | activate_target <- function( 84 | host = "localhost", port = 9222, secure = FALSE, target_id 85 | ) { 86 | target_method(host, port, secure, target_id, "activate") 87 | } 88 | 89 | #' @rdname http-methods 90 | #' @export 91 | close_target <- function( 92 | host = "localhost", port = 9222, secure = FALSE, target_id 93 | ) { 94 | target_method(host, port, secure, target_id, "close") 95 | } 96 | 97 | #' @rdname http-methods 98 | #' @export 99 | inspect_target <- function( 100 | host = "localhost", port = 9222, secure = FALSE, target_id 101 | ) { 102 | assert_that(is_scalar_character(target_id)) 103 | targets <- list_targets(host, port, secure) 104 | ids <- purrr::map_chr(targets, "id") 105 | index <- purrr::detect_index(ids, ~ identical(.x, target_id)) 106 | if(index == 0) { 107 | stop("Wrong target_id.") 108 | } 109 | if(!interactive()) { 110 | warning("The inspect method can only be used in an interactive session.") 111 | return(NULL) 112 | } 113 | path <- purrr::pluck(targets, index, "devtoolsFrontendUrl") 114 | url <- build_http_url(host, port, secure, path) 115 | browse_url(url) 116 | } 117 | 118 | fetch_json <- function(host, port, secure, method, query = NULL) { 119 | check_host_port_args(host, port) 120 | url <- build_http_url(host, port, secure, path = c("json", method), query) 121 | tryCatch( 122 | from_json(url), 123 | error = function(e) { 124 | rlang::abort( 125 | message = sprintf("json protocol cannot be reached at %s.", url), 126 | parent = e) 127 | } 128 | ) 129 | } 130 | 131 | target_method <- function(host, port, secure, target_id, method) { 132 | check_host_port_args(host, port) 133 | assert_that(is_scalar_character(target_id)) 134 | url <- build_http_url(host, port, secure, path = c("json", method, target_id)) 135 | res <- httr::GET(url, httr::use_proxy("")) 136 | !httr::http_error(res) 137 | } 138 | 139 | check_host_port_args <- function(host, port) { 140 | assert_that(is_scalar_character(host)) 141 | assert_that(is.scalar(port)) 142 | if(!is.number(port) && !is_scalar_character(port)) { 143 | stop("port must be a character or a numeric scalar.") 144 | } 145 | } 146 | 147 | from_json <- function(path) { 148 | jsonlite::fromJSON( 149 | path, 150 | simplifyVector = TRUE, 151 | simplifyDataFrame = FALSE, 152 | simplifyMatrix = FALSE 153 | ) 154 | } 155 | 156 | read_local_protocol <- function() { 157 | js_protocol <- from_json(local_protocol_file("js")) 158 | browser_protocol <- from_json(local_protocol_file("browser")) 159 | browser_protocol$domains <- c(browser_protocol$domains, js_protocol$domains) 160 | browser_protocol 161 | } 162 | 163 | local_protocol_file <- function(file = c("js", "browser")) { 164 | file <- match.arg(file) 165 | system.file("protocol", paste0(file, "_protocol.json"), package = "crrri", mustWork = TRUE) 166 | } 167 | 168 | browse_url <- function(url) { 169 | localhost <- is_localhost(url) 170 | viewer <- getOption("viewer") 171 | if (is.null(viewer) || !localhost){ 172 | utils::browseURL(url) 173 | } else { 174 | # we know here that we are probably in RStudio 175 | # we need RStudio > 1.2.xx to inspect properly headless Chrome 176 | # nocov start 177 | if(requireNamespace("rstudioapi", quietly = TRUE) && rstudioapi::isAvailable("1.2")) { 178 | viewer(url, height = "maximize") 179 | } else { 180 | utils::browseURL(url) 181 | } 182 | # nocov end 183 | } 184 | } 185 | 186 | is_localhost <- function(url) { 187 | host <- httr::parse_url(url)$hostname 188 | if(is.null(host)) { 189 | return(FALSE) 190 | } 191 | host %in% c("localhost", "127.0.0.1") 192 | } 193 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | test_that("as_predicate can be used with formula, function or a value to match identically", { 2 | expect_true(as_predicate(~ .x == 3L)(3L)) 3 | expect_true(as_predicate(3L)(3L)) 4 | expect_true(as_predicate(is.integer)(3L)) 5 | }) 6 | 7 | test_that("A character value is used to build a predicate with identical", { 8 | # a character is not passed to rlang::as_function 9 | # identical is used to create a predicate 10 | expect_false(as_predicate("is.integer")(3L)) 11 | expect_true(as_predicate("is.integer")("is.integer")) 12 | }) 13 | 14 | test_that("as_predicate controls that the result of a function is TRUE or FALSE", { 15 | f <- as_predicate(as.character) 16 | expect_error(f(1)) 17 | f <- as_predicate(~ TRUE) 18 | expect_identical(f(1), TRUE) 19 | }) 20 | 21 | test_that("combine_predicates function returns TRUE if there is no predicate function", { 22 | f <- combine_predicates(list()) 23 | expect_identical(f(list(a = 1, b = 2)), TRUE) 24 | }) 25 | 26 | test_that("combine_predicates function returns TRUE if the predicates are met", { 27 | f <- combine_predicates(list(a = function(x) x == 1, b = function(x) x == 2)) 28 | expect_identical(f(list(b = 2)), FALSE) 29 | expect_identical(f(list(a = 1, b = 1)), FALSE) 30 | expect_identical(f(list(a = 1, b = 2)), TRUE) 31 | expect_identical(f(list(a = 1, b = 2, c = 3)), TRUE) 32 | }) 33 | 34 | test_that("we can built an event listener that takes predicates as arguments and return a predicate function", { 35 | build_predicate <- function(a, b, callback = NULL) { 36 | predicate_fun <- 37 | rlang::fn_fmls_names() %>% # pick the fun arguments 38 | utils::head(-1) %>% # remove the callback argument 39 | rlang::env_get_list(nms = ., inherit = TRUE) %>% # retrieve arguments values 40 | purrr::discard(~ purrr::is_null(.x)) %>% # remove arguments identical to NULL 41 | purrr::map(as_predicate) %>% 42 | combine_predicates() 43 | predicate_fun 44 | } 45 | f <- build_predicate(a = ~ .x == 1, b = ~ .x == 2) 46 | expect_identical(f(list(b = 2)), FALSE) 47 | expect_identical(f(list(a = 1, b = 1)), FALSE) 48 | expect_identical(f(list(a = 1, b = 2)), TRUE) 49 | expect_identical(f(list(a = 1, b = 2, c = 3)), TRUE) 50 | }) 51 | 52 | test_that("new_callback_wrapper only works on function (lambda or not)", { 53 | expect_silent(new_callback_wrapper(identity, identity)) 54 | expect_error(new_callback_wrapper('identity', identity)) 55 | expect_error(new_callback_wrapper(identity, 'identity')) 56 | expect_silent(new_callback_wrapper(rlang::as_function( ~ .x == 3L), identity)) 57 | }) 58 | 59 | test_that("new_callback_wrapper result prints correctly", { 60 | expect_identical(capture.output(print(new_callback_wrapper(identity, identity))), 61 | c("=== wrapper over function ===", "function (x) ", "x ")) 62 | }) 63 | 64 | test_that("new_callback_wrapper wraps callback in the function", { 65 | wrapped_fun <- new_callback_wrapper(identity, sum) 66 | expect_s3_class(wrapped_fun, "crrri_callback_wrapper") 67 | expect_equivalent(attr(wrapped_fun, "callback"), sum) 68 | expect_identical(wrapped_fun(1), identity(1)) 69 | wrapped_fun2 <- new_callback_wrapper(as.character, wrapped_fun) 70 | expect_s3_class(wrapped_fun2, "crrri_callback_wrapper") 71 | # the callback is the one from wrapped_fun 72 | expect_equivalent(attr(wrapped_fun2, "callback"), sum) 73 | expect_identical(wrapped_fun2(1), "1") 74 | }) 75 | 76 | test_that("kill_zombie kills Chrome", { 77 | zombie <- Chrome$new(debug_port = 6666L) 78 | expect_message(kill_zombie(6666), "killed") 79 | expect_error(hold(CDPSession(port = 6666))) 80 | expect_false(zombie$is_alive()) 81 | }) 82 | 83 | test_that("is_user_port is between 1024 and 49151", { 84 | expect_true(is_user_port(1056)) 85 | expect_true(is_user_port(1024)) 86 | expect_true(is_user_port(49151)) 87 | expect_false(is_user_port(1000)) 88 | expect_false(is_user_port(50000)) 89 | }) 90 | 91 | test_that("build_http_url", { 92 | expect_identical( 93 | build_http_url("localhost", 9222, TRUE, "path", "query"), 94 | "https://localhost:9222/path?query" 95 | ) 96 | expect_identical( 97 | build_http_url("127.0.0.1", 9222, FALSE, "path", "query"), 98 | "http://127.0.0.1:9222/path?query" 99 | ) 100 | }) 101 | 102 | test_that("parse_ws_url handles wrong parameter", { 103 | expect_null(parse_ws_url("http://localhost")) 104 | expect_null(parse_ws_url("ws://")) 105 | expect_null(parse_ws_url("ws://localhost")) 106 | expect_null(parse_ws_url("ws://localhost:9222/xxx/yyyy")) 107 | expect_null(parse_ws_url("ws://localhost:9222/xxx/yyyy/zzzz/aaaaaa")) 108 | expect_null(parse_ws_url("ws://localhost:9222/xxx/yyyy/zzzz")) 109 | expect_null(parse_ws_url("ws://localhost:9222/devtools/yyyy/zzzz")) 110 | expect_null(parse_ws_url("ws://localhost:9222/devtools/pages/zzzz")) 111 | expect_null(parse_ws_url("ws://localhost:9222/devtools/browsers/zzzz")) 112 | }) 113 | 114 | test_that("parse_ws_url handles ws and wss url", { 115 | url <- "ws://localhost:9222/devtools/page/1676G76J" 116 | parsed <- parse_ws_url(url) 117 | expect_s3_class(parsed, "cdp_ws_url") 118 | expect_mapequal(parsed, list( 119 | host = "localhost", 120 | port = "9222", 121 | secure = FALSE, 122 | type = "page", 123 | id = "1676G76J" 124 | )) 125 | url <- "wss://localhost:9222/devtools/page/1676G76J" 126 | parsed <- parse_ws_url(url) 127 | expect_s3_class(parsed, "cdp_ws_url") 128 | expect_mapequal(parsed, list( 129 | host = "localhost", 130 | port = "9222", 131 | secure = TRUE, 132 | type = "page", 133 | id = "1676G76J" 134 | )) 135 | }) 136 | 137 | test_that("build_ws_url handles only crrri ws url", { 138 | expect_error(build_ws_url(list( 139 | host = "localhost", 140 | port = "9222", 141 | secure = FALSE, 142 | type = "page", 143 | id = "1676G76J" 144 | ))) 145 | parsed <- structure(list( 146 | host = "localhost", 147 | port = "9222", 148 | secure = FALSE, 149 | type = "page", 150 | id = "1676G76J" 151 | ), class = "cdp_ws_url") 152 | expect_identical(build_ws_url(parsed), "ws://localhost:9222/devtools/page/1676G76J") 153 | parsed <- structure(list( 154 | host = "localhost", 155 | port = "9222", 156 | secure = TRUE, 157 | type = "page", 158 | id = "1676G76J" 159 | ), class = "cdp_ws_url") 160 | expect_identical(build_ws_url(parsed), "wss://localhost:9222/devtools/page/1676G76J") 161 | }) 162 | 163 | test_that("stop_or_reject handles async", { 164 | expect_error(stop_or_reject("error", FALSE), "^error$") 165 | expect_error(hold(stop_or_reject("error", TRUE)), "^error$") 166 | }) 167 | 168 | test_that("check integerish accepts integer without L but not double", { 169 | expect_true(is_scalar_integerish(10)) 170 | expect_true(is_scalar_integerish(10L)) 171 | expect_false(is_scalar_integerish(10.5)) 172 | }) 173 | 174 | 175 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | # assertthat helpers ------------------------------------------------------ 2 | 3 | is_scalar_character <- function(x) { 4 | rlang::is_scalar_character(x) 5 | } 6 | 7 | assertthat::on_failure(is_scalar_character) <- function(call, env) { 8 | paste0(deparse(call$x), " is not a character scalar (a length one character vector).") 9 | } 10 | 11 | is_scalar_integerish <- function(x) { 12 | rlang::is_scalar_integerish(x) 13 | } 14 | 15 | assertthat::on_failure(is_scalar_integerish) <- function(call, env) { 16 | paste0(deparse(call$x), " is not an integer scalar (a length one integer vector).") 17 | } 18 | 19 | is_user_port <- function(x) { 20 | x >= 1024 && x <= 49151 21 | } 22 | 23 | assertthat::on_failure(is_user_port) <- function(call, env) { 24 | paste0(deparse(call$x), " is not an allowed port number (it must be in the range 1024-49151).") 25 | } 26 | 27 | is_available_port <- function(x) { 28 | tryCatch({ 29 | srv <- httpuv::startServer("127.0.0.1", x, list()) 30 | on.exit(srv$stop()) 31 | TRUE 32 | }, 33 | error = function(e) FALSE 34 | ) 35 | } 36 | 37 | assertthat::on_failure(is_available_port) <- function(call, env) { 38 | paste0("Port ", deparse(call$x), " already in use. Maybe is headless Chrome already running?") 39 | } 40 | 41 | is_function <- function(x) { 42 | rlang::is_function(x) 43 | } 44 | 45 | assertthat::on_failure(is_function) <- function(call, env) { 46 | paste0(deparse(call$x), "must be a function.") 47 | } 48 | 49 | is_single_param_fun <- function(x) { 50 | assertthat::assert_that(is_function(x)) 51 | length(rlang::fn_fmls(x)) == 1L 52 | } 53 | 54 | assertthat::on_failure(is_single_param_fun) <- function(call, env) { 55 | paste0("Function ", deparse(call$x), " must have one parameter and only one.") 56 | } 57 | 58 | check_is_single_param_fun <- function(x) { 59 | assertthat::assert_that(is_single_param_fun(x)) 60 | } 61 | 62 | is_list <- function(x) { 63 | rlang::is_list(x) 64 | } 65 | 66 | assertthat::on_failure(is_list) <- function(call, env) { 67 | paste0(deparse(call$x), " must be a list.") 68 | } 69 | 70 | # http helpers ------------------------------------------------------------ 71 | 72 | is_remote_reachable <- function(host, port, secure, retry_delay = 0.2, max_attempts = 15L) { 73 | url <- build_http_url(host = host, port = port, secure = secure) 74 | remote_reached <- function(url) { 75 | check_url <- purrr::safely(httr::GET, otherwise = list()) 76 | response <- check_url(url, httr::use_proxy("")) 77 | isTRUE(response$result$status_code == 200) 78 | } 79 | 80 | succeeded <- FALSE 81 | "!DEBUG Trying to find `url`" 82 | for (i in 1:max_attempts) { 83 | "!DEBUG attempt `i`..." 84 | succeeded <- remote_reached(url) 85 | if (isTRUE(succeeded)) break 86 | Sys.sleep(retry_delay) 87 | } 88 | 89 | "!DEBUG `if(succeeded) paste(url, 'found') else paste('...cannot find', url)`" 90 | succeeded 91 | } 92 | 93 | build_http_url <- function(host, port, secure, path = NULL, query = NULL) { 94 | scheme <- if(isTRUE(secure)) "https" else "http" 95 | httr::modify_url("", scheme = scheme, hostname = host, port = port, path = path, query = query) 96 | } 97 | 98 | parse_ws_url <- function(ws_url) { 99 | # NOTE: ws_url must be a character scalar 100 | ws_url <- httr::parse_url(ws_url) 101 | # ws_url scheme must be ws or wss: 102 | if(!identical(ws_url$scheme, "ws") && !identical(ws_url$scheme, "wss")) { 103 | return(NULL) 104 | } 105 | # ws_url must contain a hostname: 106 | if(is.null(ws_url$hostname)) { 107 | return(NULL) 108 | } 109 | # ws_url must contain a port: 110 | if(is.null(ws_url$port)) { 111 | return(NULL) 112 | } 113 | # ws_url path must be of the form devtools/page/xxxx or devtools/browser/xxx-yyy 114 | path <- strsplit(ws_url$path, "/")[[1]] 115 | if(length(path) != 3L) { 116 | return(NULL) 117 | } 118 | if(!identical(path[1:2], c("devtools", "page")) && 119 | !identical(path[1:2], c("devtools", "browser")) 120 | ) { 121 | return(NULL) 122 | } 123 | 124 | structure( 125 | list( 126 | host = ws_url$hostname, 127 | port = ws_url$port, 128 | secure = identical(ws_url$scheme, "wss"), 129 | type = path[2], 130 | id = path[3] 131 | ), 132 | class = "cdp_ws_url" 133 | ) 134 | } 135 | 136 | build_ws_url <- function(ws_url) { 137 | stopifnot(inherits(ws_url, "cdp_ws_url")) 138 | scheme <- if(ws_url$secure) "wss" else "ws" 139 | path <- c("devtools", ws_url$type, ws_url$id) 140 | httr::modify_url( 141 | "", 142 | scheme = scheme, 143 | hostname = ws_url$host, 144 | port = ws_url$port, 145 | path = path 146 | ) 147 | } 148 | 149 | # miscellaneous ----------------------------------------------------------- 150 | 151 | stop_or_reject <- function(message, async = FALSE) { 152 | err <- simpleError(message) 153 | if(isTRUE(async)) { 154 | return(promises::promise_reject(err)) 155 | } 156 | stop(err) 157 | } 158 | 159 | #' create a predicate from various forms 160 | #' 161 | #' @param arg a function, a formula or a value that will be tested as identical 162 | #' @param env see env from `rlang::as_function` 163 | #' 164 | #' @return a function that will apply the predicate and return TRUE or FALSE 165 | #' @noRd 166 | as_predicate <- function(arg, env = rlang::caller_env()) { 167 | if(rlang::is_formula(arg) || rlang::is_function(arg)) { 168 | fun <- rlang::as_function(arg, env = env) 169 | } else { 170 | fun <- function(x) identical(x, arg) 171 | } 172 | 173 | function(...) { 174 | res <- fun(...) 175 | if(!rlang::is_true(res) && !rlang::is_false(res)) { 176 | stop("Predicate functions must return a single `TRUE` or `FALSE`.") 177 | } 178 | res 179 | } 180 | } 181 | 182 | #' Combine predicates 183 | #' 184 | #' @param list_of_predicates A named list of predicates. 185 | #' 186 | #' @return A function that take a single parameter. The argument of the 187 | #' returned function is expected to be a named list. The predicates 188 | #' function are applied to the objects of the result 189 | #' @noRd 190 | combine_predicates <- function(list_of_predicates) { 191 | if(length(list_of_predicates) == 0) return(function(...) TRUE) 192 | function(result) { 193 | # if a name of a predicate is missing in the result object, return FALSE early 194 | if(length(setdiff(names(list_of_predicates), names(result))) > 0) { 195 | return(FALSE) 196 | } 197 | bool <- purrr::imap_lgl(list_of_predicates, ~ .x(result[[.y]])) 198 | all(bool) 199 | } 200 | } 201 | 202 | 203 | # callbacks wrappers ------------------------------------------------------ 204 | dewrap <- function(x, ...) { 205 | UseMethod("dewrap", x) 206 | } 207 | 208 | dewrap.default <- function(x, ...) { 209 | x 210 | } 211 | 212 | dewrap.crrri_callback_wrapper <- function(x, ...) { 213 | attr(x, "callback", exact = TRUE) 214 | } 215 | 216 | format.crrri_callback_wrapper <- function(x, ...) { 217 | format_object <- paste(collapse = "\n", format(dewrap(x))) 218 | paste("=== wrapper over function ===", format_object, sep = "\n") 219 | } 220 | 221 | print.crrri_callback_wrapper <- function(x, ...) { 222 | cat(format(x), "\n") 223 | } 224 | 225 | new_callback_wrapper <- function(wrapper_fn, callback) { 226 | stopifnot(rlang::is_function(wrapper_fn), rlang::is_function(callback)) 227 | attr(wrapper_fn, "callback") <- dewrap(callback) 228 | if(!inherits(wrapper_fn, "crrri_callback_wrapper")) { 229 | class(wrapper_fn) <- c("crrri_callback_wrapper", class(wrapper_fn)) 230 | } 231 | wrapper_fn 232 | } 233 | 234 | 235 | # kill a zombie Chrome ---------------------------------------------------- 236 | # this is because sometimes my R session crashes and I get a zombie Chrome 237 | kill_zombie <- function(port = 9222) { 238 | client <- hold(CDPSession(port = port)) 239 | hold(client$Browser$close()) 240 | if(client$readyState() == 3L) { 241 | message("zombie killed!") 242 | } else { 243 | message("zombie is still alive!") # nocov 244 | } 245 | } 246 | -------------------------------------------------------------------------------- /R/EventEmitter.R: -------------------------------------------------------------------------------- 1 | #' @include utils.R 2 | NULL 3 | 4 | #' R6 class to emit some event 5 | #' 6 | #' This is a general purpose class to build on. It is inspired by the node.js EventEmitter class. 7 | #' See . 8 | #' 9 | #' @name EventEmitter 10 | #' @examples 11 | #' myEmitter <- EventEmitter$new() 12 | #' myEmitter$on("event", 13 | #' function() { 14 | #' message("an event occured!") 15 | #' } 16 | #' ) 17 | #' myEmitter$emit("event") 18 | #' # The listener is still called when "event" fires: 19 | #' myEmitter$emit("event") 20 | #' # A listener can be registered once: 21 | #' myEmitter$once("event", 22 | #' function() { 23 | #' message("this listener is called only once") 24 | #' } 25 | #' ) 26 | #' # This new listener will be removed when called. 27 | #' myEmitter$emit("event") 28 | #' # There is now only one listener: 29 | #' myEmitter$emit("event") 30 | #' 31 | #' # An error in a listener will throw an error in R. 32 | #' myEmitter$on("event", function(...) stop("An error in a listener")) 33 | #' # Throw an error: 34 | #' \dontrun{ 35 | #' myEmitter$emit("event")} 36 | #' 37 | #' # You can catch an error with a special "error" event that is 38 | #' # always emitted when an error occured in a listener: 39 | #' myEmitter$on("error", function(e) cat(conditionMessage(e))) 40 | #' myEmitter$emit("event") 41 | #' 42 | #' # As in the node.js class, a "newListener" event is emitted 43 | #' # before each new listener registration. 44 | #' # The "newListener" event passes two arguments to its listener(s): 45 | #' # `eventName` and `listener`. 46 | #' myEmitter <- EventEmitter$new() 47 | #' # Use once here to avoid infinite recursion: 48 | #' myEmitter$once("newListener", function(eventName, listener) { 49 | #' if(eventName == "event") { 50 | #' myEmitter$on("event", function(...) cat("B")) 51 | #' } 52 | #' }) 53 | #' myEmitter$on("event", function(...) cat("A")) 54 | #' myEmitter$emit("event") # BA 55 | #' # The listener attached to the "newListener" event has been 56 | #' # unregistered and is no more called: 57 | #' myEmitter$on("event", function(...) cat("C")) 58 | #' myEmitter$emit("event") # BAC 59 | #' 60 | #' # Get the number of listeners for an event: 61 | #' myEmitter$listenerCount("event") 62 | #' 63 | #' # Get the event names which have been registered: 64 | #' myEmitter$eventNames() 65 | NULL 66 | 67 | #' @rdname EventEmitter 68 | #' @export 69 | EventEmitter <- R6::R6Class( 70 | "EventEmitter", 71 | private = list( 72 | .queues = list(), 73 | .queue_exists = function(eventName) { 74 | queue <- private$.queues[[eventName]] 75 | length(queue) > 0 76 | }, 77 | .has_listeners = function(eventName) { 78 | self$listenerCount(eventName) > 0 79 | }, 80 | .check_queue = function(eventName) { 81 | if (!private$.queue_exists(eventName)) { 82 | private$.queues[[eventName]] <- CallbacksQueue$new() 83 | } 84 | } 85 | ), 86 | public = list( 87 | emit = function(eventName, ...) { 88 | "!DEBUG emit: event '`eventName`'" 89 | if (private$.has_listeners(eventName)) { 90 | private$.queues[[eventName]]$invoke( 91 | ..., 92 | onError = function(e) self$emit("error", e) 93 | ) 94 | } else { 95 | # throw error if no listener registered for 'error' event 96 | if (eventName == "error") { 97 | stop(...) 98 | } 99 | } 100 | invisible(self) 101 | }, 102 | on = function(eventName, listener) { 103 | listener <- rlang::as_function(listener) 104 | "!DEBUG on: registering a listener on event '`eventName`'" 105 | private$.check_queue(eventName) 106 | "!DEBUG on: emit 'newListener' event on event '`eventName`'" 107 | self$emit("newListener", eventName, listener) 108 | invisible(private$.queues[[eventName]]$append(listener)) 109 | }, 110 | addListener = function(eventName, listener) { 111 | self$on(eventName, listener) 112 | }, 113 | once = function(eventName, listener) { 114 | listener <- rlang::as_function(listener) 115 | "!DEBUG once: registering a listener on event '`eventName`' for once" 116 | private$.check_queue(eventName) 117 | remove_listener <- NULL 118 | new_listener <- once_function(function(...) { 119 | # unregister callback before calling 120 | "!DEBUG once: removing listener for event '`eventName`'" 121 | remove_listener() 122 | "!DEBUG once: emit removeListener event for '`eventName`'" 123 | self$emit("removeListener", eventName, listener) 124 | "!DEBUG once: call listener for event '`eventName`'" 125 | listener(...) 126 | }) 127 | new_listener <- new_callback_wrapper(new_listener, listener) 128 | self$emit("newListener", eventName, listener) 129 | remove_listener <- private$.queues[[eventName]]$append(new_listener) 130 | invisible(remove_listener) 131 | }, 132 | listenerCount = function(eventName) { 133 | stopifnot(!missing(eventName)) 134 | if (private$.queue_exists(eventName)) { 135 | private$.queues[[eventName]]$count() 136 | } else { 137 | 0L 138 | } 139 | }, 140 | eventNames = function() { 141 | queues_names <- names(private$.queues) 142 | Filter(private$.has_listeners, queues_names) 143 | }, 144 | rawListeners = function(eventName) { 145 | stopifnot(!missing(eventName)) 146 | if (private$.queue_exists(eventName)) { 147 | private$.queues[[eventName]]$get() 148 | } else { 149 | list() 150 | } 151 | }, 152 | listeners = function(eventName) { 153 | stopifnot(!missing(eventName)) 154 | rawListeners <- self$rawListeners(eventName) 155 | # workaround an error in R CMD check 156 | # embed the S3 generic in another function: 157 | get_listener <- function(x) dewrap(x) 158 | purrr::map(rawListeners, get_listener) 159 | } 160 | ) 161 | ) 162 | 163 | # CallbacksQueue ---------------------------------------------------------- 164 | CallbacksQueue <- R6::R6Class( 165 | "CallbacksQueue", 166 | inherit = Queue, 167 | public = list( 168 | invoke = function(..., onError = stop) { 169 | callbacks <- super$get() 170 | for(callback in callbacks) { 171 | tryCatch(callback(...), error = function(e) onError(e)) 172 | } 173 | } 174 | ) 175 | ) 176 | 177 | # Queue class ------------------------------------------------------------- 178 | Queue <- R6::R6Class( 179 | "Queue", 180 | private = list( 181 | .queue = list(), 182 | .wrap = function(element) { 183 | wrapper <- new.env(parent = emptyenv(), size = 1L) 184 | wrapper$element <- element 185 | wrapper 186 | }, 187 | .rm_wrapper = function(wrapper) { 188 | element <- wrapper$element 189 | queue <- private$.queue 190 | # Since wrappers are environments, identical() will always send back at most one element. 191 | # This is the main trick. 192 | pos <- Position(function(x) identical(x, wrapper), queue) 193 | queue[pos] <- NULL 194 | private$.queue <- queue 195 | element 196 | } 197 | ), 198 | public = list( 199 | append = function(element) { 200 | wrapper <- private$.wrap(element) 201 | private$.queue <- c(private$.queue, list(wrapper)) 202 | function() {private$.rm_wrapper(wrapper)} 203 | }, 204 | prepend = function(element) { 205 | wrapper <- private$.wrap(element) 206 | private$.queue <- c(list(wrapper), private$.queue) 207 | function() {private$.rm_wrapper(wrapper)} 208 | }, 209 | get = function() { 210 | purrr::map(private$.queue, ~ get("element", pos = .x)) 211 | }, 212 | remove_element = function(element, right = TRUE) { 213 | queue <- private$.queue 214 | pos <- Position(function(x) identical(x$element, element), queue, right = right) 215 | queue[pos] <- NULL 216 | private$.queue <- queue 217 | element 218 | }, 219 | count = function() { 220 | length(private$.queue) 221 | } 222 | ) 223 | ) 224 | 225 | once_function <- function(fun) { 226 | done <- FALSE 227 | res <- function(...) { 228 | run <- !done 229 | done <<- TRUE 230 | if (run) fun(...) 231 | } 232 | class(res) <- c("once_function", "function") 233 | return(new_callback_wrapper(res, fun)) 234 | } 235 | -------------------------------------------------------------------------------- /tests/testthat/test-Chrome.R: -------------------------------------------------------------------------------- 1 | context("test-chrome") 2 | 3 | test_that("we get the proxy env var correctly", { 4 | expect_identical(get_proxy(), "") 5 | withr::with_envvar( 6 | c(https_proxy = "dummy"), 7 | expect_identical(get_proxy(), "dummy") 8 | ) 9 | withr::with_envvar( 10 | c(HTTP_PROXY = "dummy"), 11 | expect_identical(get_proxy(), "dummy") 12 | ) 13 | }) 14 | 15 | test_that("Proxy is correctly passed to chrome", { 16 | expect_identical(get_no_proxy_urls(), c("localhost", "127.0.0.1")) 17 | old <- Sys.getenv("NO_PROXY") 18 | Sys.setenv(NO_PROXY = "noproxy1;noproxy2,noproxy3") 19 | expect_identical(get_no_proxy_urls(), 20 | c("localhost", "127.0.0.1", "noproxy1", "noproxy2", "noproxy3") 21 | ) 22 | Sys.setenv(NO_PROXY = old) 23 | old <- Sys.getenv("no_proxy") 24 | Sys.setenv(no_proxy = "noproxy1;noproxy2,localhost") 25 | expect_identical(get_no_proxy_urls(), 26 | c("localhost", "127.0.0.1", "noproxy1", "noproxy2") 27 | ) 28 | Sys.setenv(no_proxy = old) 29 | }) 30 | 31 | test_that("Use specify chrome if set", { 32 | withr::with_envvar( 33 | c(HEADLESS_CHROME = "path/to/chrome"), 34 | expect_identical(find_chrome_binary(), "path/to/chrome") 35 | ) 36 | }) 37 | 38 | setup_chrome_test() 39 | 40 | test_that("is_alive() returns a logical", { 41 | expect_is(chrome$is_alive(), "logical") 42 | }) 43 | 44 | test_that("Chrome cannot be launched if the port is already used", { 45 | expect_error(Chrome$new()) 46 | }) 47 | 48 | test_that("Chrome$new() returns a Chrome class object", { 49 | expect_is(chrome, "Chrome") 50 | expect_is(chrome, "CDPRemote") 51 | expect_is(chrome, "R6") 52 | }) 53 | 54 | test_that("Chrome object can be safely printed", { 55 | expect_output(print(chrome)) 56 | }) 57 | 58 | test_that("connect() returns a CDPSession object that is closed with closeConnections()", { 59 | client_pr <- chrome$connect() 60 | expect_is(client_pr, "promise") 61 | client <- hold(client_pr) 62 | expect_is(client, "CDPSession") 63 | closed_pr <- chrome$closeConnections() 64 | expect_is(closed_pr, "promise") 65 | closed_pr_value <- hold(closed_pr) 66 | expect_reference(closed_pr_value, chrome) 67 | expect_equivalent(client$readyState(), 3L) 68 | }) 69 | 70 | test_that("connect() can take a target_id as argument", { 71 | target_id <- list_targets()[[1]]$id 72 | client_pr <- chrome$connect(.target_id = target_id) 73 | expect_is(client_pr, "promise") 74 | client <- hold(client_pr) 75 | expect_is(client, "CDPSession") 76 | hold(client$disconnect()) 77 | }) 78 | 79 | test_that("connect() throws an error or returns a rejected promise if target_id is wrong", { 80 | target_id <- "1234" 81 | client_pr <- chrome$connect(.target_id = target_id) 82 | expect_is(client_pr, "promise") 83 | expect_error(hold(client_pr)) 84 | expect_error(chrome$connect(.target_id = target_id, callback = function(client){})) 85 | }) 86 | 87 | test_that("connect() creates a new tab if there is no tab", { 88 | client <- hold(chrome$connect()) 89 | hold(client$closeTab()) 90 | expect_length(list_targets(), 0L) 91 | client <- chrome$connect() 92 | expect_is(client, "promise") 93 | expect_silent(hold(client)) 94 | hold(chrome$closeConnections()) 95 | }) 96 | 97 | test_that("closeConnections() returns a promise which fulfills when connections are closed. Its value is the remote object.", { 98 | client <- hold(chrome$connect()) 99 | client2 <- hold(chrome$connect()) 100 | expect_identical(length(chrome$listConnections()), 2L) 101 | res <- hold(chrome$closeConnections()) 102 | expect_reference(res, chrome) 103 | expect_identical(length(chrome$listConnections()), 0L) 104 | # same thing without any connection 105 | res <- hold(chrome$closeConnections()) 106 | expect_reference(res, chrome) 107 | }) 108 | 109 | test_that("closeConnections() with a callback argument", { 110 | client <- hold(chrome$connect()) 111 | client2 <- hold(chrome$connect()) 112 | res <- NULL 113 | chrome$closeConnections(callback = function(x){res <<- x}) 114 | hold(chrome$closeConnections()) 115 | expect_reference(res, chrome) 116 | # re-run test without any connection 117 | res <- NULL 118 | expect_identical(length(chrome$listConnections()), 0L) 119 | chrome$closeConnections(callback = function(x){res <<- x}) 120 | hold(chrome$closeConnections()) 121 | expect_reference(res, chrome) 122 | }) 123 | 124 | test_that("close() returns the Chrome object", { 125 | closed <- chrome$close() 126 | expect_reference(closed, chrome) 127 | }) 128 | 129 | test_that("once closed, is_alive() return FALSE", { 130 | expect_identical(chrome$is_alive(), FALSE) 131 | }) 132 | 133 | 134 | context("test perform_with_chrome") 135 | 136 | test_that("funs pass as .list must be a list", { 137 | fun <- function(client) 1 138 | expect_error(perform_with_chrome(.list = fun), regexp = ".list must be a list") 139 | }) 140 | 141 | test_that("With only 1 argument perform_with_chrome() returns the value of the async function invisibly", { 142 | value <- runif(1) 143 | async_fun <- function(client) { 144 | promises::promise_resolve(value) 145 | } 146 | expect_identical(perform_with_chrome(async_fun), value) 147 | # if not async, return invisibly 148 | expect_invisible(perform_with_chrome(async_fun, async = FALSE)) 149 | # if async, result is a promise 150 | pr <- perform_with_chrome(async_fun, async = TRUE) 151 | expect_s3_class(pr, "promise") 152 | hold(pr) 153 | }) 154 | 155 | test_that("With multiple argument, perform_with_chrome() returns a list with the values of the async functions if they are not NULL", { 156 | values <- as.list(runif(3)) 157 | async_funs <- purrr::map(values, ~ function(client) promises::promise_resolve(.x)) 158 | expect_identical(do.call(perform_with_chrome, async_funs), values) 159 | }) 160 | 161 | test_that("With multiple arguments, if one of the async function returns NULL, ensure that the length of the result list is equal to the number of funs", { 162 | values <- vector("list", 3L) 163 | async_funs <- purrr::map(values, ~ function(client) promises::promise_resolve(.x)) 164 | expect_length(do.call(perform_with_chrome, async_funs), length(values)) 165 | }) 166 | 167 | test_that("rejects if one promises get rejected", { 168 | async_funs <- list(fun1 = function(client) promises::promise_resolve(1L), 169 | fun2 = function(client) promises::promise_reject("fun2 rejected")) 170 | expect_error(perform_with_chrome(.list = async_funs), "fun2 rejected") 171 | }) 172 | 173 | test_that("timeouts are respected and recycled (using JS in chrome)", { 174 | async_fun <- function(ms) { 175 | function(client) { 176 | Runtime <- client$Runtime 177 | Runtime$enable() %...>% { 178 | Runtime$evaluate( 179 | expression = paste0( 180 | 'function sleep(ms) {', 181 | 'return new Promise(resolve => setTimeout(resolve, ms));', 182 | '};', 183 | 'async function wait() {', 184 | 'var n = Date.now();', 185 | 'await sleep(', ms, ');', 186 | 'var n2 = Date.now()-n;', 187 | 'console.log(n2); return n2;}', 188 | 'wait();'), 189 | awaitPromise = TRUE 190 | )} 191 | } 192 | } 193 | async_funs <- list( 194 | async_fun(500), 195 | async_fun(3000) 196 | ) 197 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(30, 1)), 198 | "The delay of 1 seconds expired in async function n-2.") 199 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(2)), 200 | "The delay of 2 seconds expired in async function n-2.") 201 | skip_on_os("windows") 202 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(1)), 203 | "The delay of 1 seconds expired in async function n-2.") 204 | }) 205 | 206 | test_that("timeouts are respected and recycled (using R only)", { 207 | async_funs <- list( 208 | function(client) { 209 | promises::promise(~later::later(~resolve(1), delay = 0)) 210 | }, 211 | function(client) { 212 | promises::promise(~later::later(~resolve(2), delay = 3)) 213 | } 214 | ) 215 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(30, 1)), 216 | "The delay of 1 seconds expired in async function n-2.") 217 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(2)), 218 | "The delay of 2 seconds expired in async function n-2.") 219 | skip_on_os("windows") 220 | expect_error(perform_with_chrome(.list = async_funs, timeouts = c(1)), 221 | "The delay of 1 seconds expired in async function n-2.") 222 | }) 223 | 224 | test_that("funs must be async functions", { 225 | fun <- function(client) 1 226 | expect_error(perform_with_chrome(fun)) 227 | }) 228 | -------------------------------------------------------------------------------- /tools/generator.R: -------------------------------------------------------------------------------- 1 | js_protocol <- jsonlite::read_json("./tools/js_protocol.json") 2 | browser_protocol <- jsonlite::read_json("./tools/browser_protocol.json") 3 | 4 | types <- c(string = "A character string. ", 5 | boolean = "A logical. ", 6 | integer = "An integer. ", 7 | array = "A list of ", 8 | number = "A numeric. ") 9 | 10 | is_param_optional <- function(parameter) { 11 | isTRUE(parameter$optional) 12 | } 13 | 14 | is_cmd_deprecated <- function(command) { 15 | isTRUE(command$deprecated) 16 | } 17 | 18 | sanitize_help <- function(text) { 19 | text <- gsub("[0..100]", "`[0..100]`", text, fixed = TRUE) 20 | text <- gsub("[0..1]", "`[0..1]`", text, fixed = TRUE) 21 | gsub("\\n", "\n#' ", text) 22 | } 23 | 24 | # Build command ----------------------------------------------------------- 25 | build_command_signature <- function(command) { 26 | par_names <- c("promise", purrr::map_chr(command$parameters, "name")) 27 | optionals <- c(FALSE, purrr::map_lgl(command$parameters, is_param_optional)) 28 | paste0("function(", 29 | paste(paste0(par_names, 30 | ifelse(optionals, " = NULL", "") 31 | ), collapse = ", "), 32 | ", awaitResult = TRUE)") 33 | } 34 | 35 | build_command_parameter_help <- function(parameter) { 36 | declaration <- paste0( 37 | "#' @param ", parameter$name, " ", 38 | if (isTRUE(parameter$deprecated)) "Deprecated. ", 39 | if (isTRUE(parameter$experimental)) "Experimental. ", 40 | if (isTRUE(parameter$optional)) "Optional. ", 41 | types[parameter$type], 42 | if (!is.null(parameter$items)) paste0(parameter$items, ". "), 43 | if (!is.null(parameter[["$ref"]])) paste0("A ", parameter[["$ref"]], ". ") 44 | ) 45 | details <- paste( 46 | parameter$description, 47 | if (!is.null(parameter$enum)) 48 | paste0("Accepted values: ", paste(parameter$enum, collapse = ", "), ".") 49 | ) 50 | text <- paste0(declaration, if (length(details) > 0) "\n", details) 51 | sanitize_help(text) 52 | } 53 | 54 | build_command_help <- function(domain_name, command) { 55 | title <- paste0("#' Send the command ", paste(domain_name, command$name, sep = "."), "\n#' ") 56 | description <- paste0("#' ", command$description) 57 | description <- paste0(sanitize_help(description), "\n#' ") 58 | params <- c("#' @param promise An asynchronous result.", 59 | purrr::map_chr(command$parameters, build_command_parameter_help), 60 | "#' @param awaitResult Await for the command result?" 61 | ) 62 | return_field <- paste0( 63 | "#' ", 64 | "\n#' @return An async value of class `promise`.", 65 | "\n#' The value and the completion of the promise differ according to the value of `awaitResult`.", 66 | "\n#' Its value is a named list of two elements: `ws` (the websocket connexion) and `result`.", 67 | "\n#' When `awaitResult` is `TRUE`, the promise is fulfilled once the result of the command is received. In this case,", 68 | if (length(command$returns) == 0) "\n#' `result` is a void named list." 69 | else sprintf("\n#' `result` is a named list of length %i.", length(command$returns)), 70 | "\n#' When `awaitResult` is `FALSE`, the promise is fulfilled once the command is sent:", 71 | "\n#' `result` is equal to the previous result (`promise$result`).", 72 | "\n#' In both cases, you can chain this promise with another command or event listener." 73 | ) 74 | paste0(c(title, description, params, return_field, "#' @export"), collapse = "\n") 75 | } 76 | 77 | generate_command <- function(command, domain_name = NULL) { 78 | r2help <- build_command_help(domain_name, command) 79 | body <- paste0(paste(domain_name, command$name, sep = "."), " <- ", build_command_signature(command), " {\n", 80 | sprintf(" method <- '%s.%s'\n", domain_name, command$name), 81 | " args <- utils::head(rlang::fn_fmls_names(), -1)\n", 82 | " args <- args[!sapply(mget(args), is.null)]\n", 83 | " params <- mget(args)\n", 84 | " params <- if (length(params) > 1) params[2:length(params)] else NULL\n", 85 | " send(promise, method, params, awaitResult)\n", 86 | "}\n") 87 | paste(r2help, body, sep = "\n") 88 | } 89 | 90 | generate_commands_source_code <- function(domain) { 91 | deprecated <- purrr::map_lgl(domain$commands, is_cmd_deprecated) 92 | commands <- domain$commands[!deprecated] 93 | file_content <- paste0(c( 94 | "# DO NOT EDIT BY HAND\n#' @include send.R\nNULL", 95 | purrr::map_chr(commands, generate_command, domain_name = domain$domain) 96 | ), collapse = "\n\n") 97 | cat(file_content, file = paste0("R/commands_", domain$domain, ".R")) 98 | } 99 | 100 | purrr::walk(js_protocol$domains, generate_commands_source_code) 101 | purrr::walk(browser_protocol$domains, generate_commands_source_code) 102 | 103 | # Build event listener ---------------------------------------------------- 104 | build_event_parameter_help <- function(parameter) { 105 | declaration <- paste0( 106 | "#' @param ", parameter$name, " ", 107 | if (isTRUE(parameter$deprecated)) "Deprecated. ", 108 | if (isTRUE(parameter$experimental)) "Experimental. ", 109 | types[parameter$type], 110 | if (!is.null(parameter$items)) paste0(parameter$items, ". "), 111 | if (!is.null(parameter[["$ref"]])) paste0("A ", parameter[["$ref"]], ". ") 112 | ) 113 | details <- paste( 114 | parameter$description, 115 | paste0("Accepted values: ", paste(c(paste0("`~ .res$", parameter$name, "` (to refer to the previous result)"), parameter$enum), collapse = ", "), ".") 116 | ) 117 | text <- paste0(declaration, if (length(details) > 0) "\n", details) 118 | sanitize_help(text) 119 | } 120 | 121 | build_event_help <- function(domain_name, event) { 122 | title <- paste0("#' Await the event ", paste(domain_name, event$name, sep = "."), " or create a callback", "\n#' ") 123 | description <- paste0("#' ", event$description) 124 | description <- paste0(sanitize_help(description), "\n#' ") 125 | params <- c("#' @param promise An asynchronous result object.", 126 | purrr::map_chr(event$parameters, build_event_parameter_help), 127 | "#' @param .callback A callback function taking one argument. The object passed to", 128 | "#' this function is the message received from Chrome: this is a named list", 129 | paste0("#' with an element `method` (that is equal to `\"", event$name, "\"`)"), 130 | "#' and an element `params` which is a named list.", 131 | if (is.null(event$parameters)) "#' For this event, `params` is void." 132 | else c( 133 | "#' The `params` list is composed of", 134 | paste0("#' the following element(s): ", 135 | paste0("`", purrr::map_chr(event$parameters, "name"), "`", 136 | ifelse(purrr::map_lgl(event$parameters, is_param_optional), " (optional) ", ""), 137 | collapse = ", " 138 | ), 139 | "." 140 | ) 141 | ) 142 | ) 143 | return_field <- paste0( 144 | "#' ", 145 | "\n#' @return An async value of class `promise`.", 146 | "\n#' The value and the completion of the promise differ according to the use of a callback function.", 147 | "\n#' When `.callback` is `NULL`, the promise is fulfilled when the event is received.", 148 | "\n#' Its value is a named list of two elements: `ws` (the websocket connexion) and `result`.", 149 | "\n#' `result` is a named list: its elements are the parameters sended by Chrome. ", 150 | "\n#' You can chain this promise with another command or event listener.", 151 | "\n#' When `.callback` is not `NULL`, the promise is fulfilled as soon as the callback is created; the value", 152 | "\n#' is a function without any argument that can be called to cancel the callback. When you use the", 153 | "\n#' `.callback` argument, you cannot send the result to any other command or event listener." 154 | ) 155 | paste0(c(title, "#' **Event description**: ", description, params, return_field, "#' @export"), collapse = "\n") 156 | } 157 | 158 | 159 | build_event_signature <- function(event) { 160 | par_names <- purrr::map_chr(event$parameters, "name") 161 | paste0("function(promise, ", if (length(par_names) > 0) paste0(paste(paste0(par_names, " = NULL"), collapse = ", "), ", "), ".callback = NULL)") 162 | } 163 | 164 | generate_event <- function(event, domain_name = NULL) { 165 | r2help <- build_event_help(domain_name, event) 166 | body <- paste0(paste(domain_name, event$name, sep = "."), " <- ", build_event_signature(event), " {\n", 167 | sprintf(" method <- '%s.%s'\n", domain_name, event$name), 168 | " args <- utils::head(rlang::fn_fmls_names(), -1)\n", 169 | " args <- args[!sapply(mget(args), is.null)]\n", 170 | " params <- mget(args)\n", 171 | " params <- if (length(params) > 1) params[2:length(params)] else NULL\n", 172 | " listen(promise, method, params, .callback)\n", 173 | "}\n") 174 | paste(r2help, body, sep = "\n") 175 | } 176 | 177 | generate_events_source_code <- function(domain) { 178 | events <- domain$events 179 | if (is.null(events)) return() 180 | file_content <- paste0(c( 181 | "# DO NOT EDIT BY HAND\n#' @include send.R\nNULL", 182 | purrr::map_chr(events, generate_event, domain_name = domain$domain) 183 | ), collapse = "\n\n") 184 | cat(file_content, file = paste0("R/events_", domain$domain, ".R")) 185 | } 186 | 187 | purrr::walk(js_protocol$domains, generate_events_source_code) 188 | purrr::walk(browser_protocol$domains, generate_events_source_code) 189 | 190 | # TODO detail the return object resulting of a command 191 | # TODO check the remote protocol (in send) 192 | 193 | 194 | -------------------------------------------------------------------------------- /tests/testthat/test-cdpsession.R: -------------------------------------------------------------------------------- 1 | context("test-cdpsession") 2 | 3 | void_cb <- function(client){} 4 | 5 | test_that("ws_url must be a character scalar", { 6 | client <- CDPSession(ws_url = 1) 7 | expect_is(client, "promise") 8 | expect_error(hold(client), regexp = "scalar") 9 | }) 10 | 11 | test_that("a malformed ws_url throws an error or rejects the promise", { 12 | client <- CDPSession(ws_url = "localhost") 13 | expect_is(client, "promise") 14 | expect_error(hold(client)) 15 | expect_error(CDPSession(ws_url = "localhost", callback = void_cb)) 16 | }) 17 | 18 | test_that("host must be a character scalar", { 19 | client <- CDPSession(host = 1) 20 | expect_is(client, "promise") 21 | expect_error(hold(client)) 22 | expect_error(CDPSession(host = c("localhost", "localhost"), callback = void_cb)) 23 | }) 24 | 25 | test_that("port must be a numeric or a character scalar", { 26 | client <- CDPSession(port = TRUE) 27 | expect_is(client, "promise") 28 | expect_error(hold(client)) 29 | expect_error(CDPSession(port = list(1, 2), callback = void_cb)) 30 | }) 31 | 32 | setup_chrome_test() 33 | 34 | test_that("ws url can be retrieved correctly", { 35 | expect_match(chr_get_ws_addr(), "ws[s]?://localhost:9222/devtools/page/[A-Z0-9]+") 36 | expect_match(chr_get_ws_addr(port = 9222), "ws[s]?://localhost:9222/devtools/page/[A-Z0-9]+") 37 | expect_error(chr_get_ws_addr(secure = TRUE), 38 | "https://localhost") 39 | }) 40 | 41 | test_that("connect and disconnect methods return promises", { 42 | client_pr <- CDPSession() 43 | expect_is(client_pr, "promise") 44 | client <- hold(client_pr) 45 | expect_is(client, "CDPSession") 46 | closed_pr <- client$disconnect() 47 | expect_is(closed_pr, "promise") 48 | closed_client <- hold(closed_pr) 49 | expect_is(closed_client, "CDPSession") 50 | expect_reference(closed_client, client) 51 | # re-run the last expectations with a closed connection 52 | expect_equivalent(client$readyState(), 3L) 53 | closed_pr <- client$disconnect() 54 | expect_is(closed_pr, "promise") 55 | closed_client <- hold(closed_pr) 56 | expect_is(closed_client, "CDPSession") 57 | expect_reference(closed_client, client) 58 | }) 59 | 60 | test_that("when callback, async is FALSE and not return a promise", { 61 | client <- CDPSession(callback = function(client) message("ok")) 62 | expect_false(promises::is.promise(client)) 63 | }) 64 | 65 | test_that("in disconnect() when using a callback, the argument passed to the callback is the connection object and disconnect() returns self", { 66 | client <- hold(CDPSession()) 67 | arg <- NULL 68 | res <- client$disconnect(callback = function(x) {arg <<- x}) 69 | hold(client$disconnect()) 70 | expect_reference(arg, client) 71 | expect_reference(res, client) 72 | # re-run the last expectations with a closed connection 73 | arg <- NULL 74 | expect_equivalent(client$readyState(), 3L) 75 | res <- client$disconnect(callback = function(x) {arg <<- x}) 76 | expect_reference(arg, client) 77 | expect_reference(res, client) 78 | }) 79 | 80 | test_that("inspect method returns NULL", { 81 | skip_if_not(interactive()) 82 | client <- hold(CDPSession()) 83 | expect_identical(client$inspect(), NULL) 84 | client$disconnect() 85 | }) 86 | 87 | test_that("CDPSession is disconnected when removed", { 88 | client <- hold(CDPSession()) 89 | expect_message(client$.__enclos_env__$private$finalize()) 90 | }) 91 | 92 | test_that("activateTab method returns a promise which fulfills to TRUE when connected and rejects when disconnected", { 93 | client <- hold(CDPSession()) 94 | activated <- client$activateTab() 95 | expect_is(activated, "promise") 96 | expect_identical(hold(activated), TRUE) 97 | client$disconnect() 98 | activated <- client$activateTab() 99 | expect_is(activated, "promise") 100 | expect_error(hold(activated)) 101 | }) 102 | 103 | test_that("closeTab method disconnects and closes target silently", { 104 | targets <- length(list_targets()) 105 | client <- hold(CDPSession()) 106 | closed_pr <- client$closeTab() 107 | expect_is(closed_pr, "promise") 108 | expect_silent(hold(closed_pr)) 109 | expect_true(hold(closed_pr)) 110 | expect_equivalent(client$readyState(), 3L) 111 | expect_equal(length(list_targets()), targets - 1L) 112 | }) 113 | 114 | test_that("connect() raises an error (or return a rejected promise) when there is no target available", { 115 | expect_length(list_targets(), 0L) 116 | client_pr <- CDPSession() 117 | expect_is(client_pr, "promise") 118 | expect_error(hold(client_pr)) 119 | }) 120 | 121 | test_that("when printed, the connection object returns informations about domains", { 122 | client <- hold(chrome$connect()) 123 | expect_output(print(client), "") 124 | }) 125 | 126 | test_that("Command-A command without a callback returns a promise whose value is a named list", { 127 | client <- hold(chrome$connect()) 128 | pr <- client$Page$enable() 129 | res <- hold(pr) 130 | expect_type(res, "list") 131 | expect_named(res) 132 | hold(client$disconnect()) 133 | }) 134 | 135 | test_that("Command-The object passed to the callback function is identical to the value of the fulfilled promise", { 136 | client <- hold(chrome$connect()) 137 | res_callback <- NULL 138 | client$Page$getFrameTree(callback = function(res) {res_callback <<- res}) 139 | later::run_now(0.1) 140 | res_pr <- hold(client$Page$getFrameTree()) 141 | expect_identical(res_callback, res_pr) 142 | hold(client$disconnect()) 143 | }) 144 | 145 | test_that("Command-rlang lambda functions can be used in callbacks", { 146 | client <- hold(chrome$connect()) 147 | res_native_fun <- NULL 148 | res_rlang_fun <- NULL 149 | client$Browser$getVersion(callback = function(res) {res_native_fun <<- res}) 150 | client$Browser$getVersion(callback = ~ {res_rlang_fun <<- .x}) 151 | hold(client$Browser$getVersion()) 152 | expect_identical(res_native_fun, res_rlang_fun) 153 | hold(client$disconnect()) 154 | }) 155 | 156 | test_that("Event listener-When a callback is used, the returned function dismisses the listener", { 157 | client <- hold(chrome$connect()) 158 | hold(client$Page$enable()) 159 | witness <- client$Page$loadEventFired() 160 | expect_s3_class(witness, "promise") 161 | callback <- function(...) stop("this error should never fires") 162 | rm_callback <- client$Page$loadEventFired(callback = callback) 163 | expect_is(rm_callback, "function") 164 | # now remove the second listener 165 | returned_callback <- rm_callback() 166 | # when we remove the listener, the original callback is returned 167 | expect_identical(callback, returned_callback) 168 | # now navigate to a page 169 | f <- function() { 170 | client$Page$navigate(url = "http://httpbin.org/status/200") 171 | hold(witness) 172 | } 173 | expect_silent(f()) 174 | hold(client$disconnect()) 175 | }) 176 | 177 | test_that("Event listener-With a predicate, without callback, a promise is returned which is fulfilled when the predicate matches", { 178 | client <- hold(chrome$connect()) 179 | hold(client$Page$enable()) 180 | frame_id <- hold(client$Page$getFrameTree())$frameTree$frame$id 181 | pr <- client$Page$frameStoppedLoading(frameId = ~ .x == frame_id) 182 | # we expect that a listener is attached to Page.frameStoppedLoading event 183 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 184 | expect_is(pr, "promise") 185 | hold(client$Page$navigate(url = "http://httpbin.org/status/200")) 186 | res <- hold(pr) 187 | expect_identical(res$frameId, frame_id) 188 | # we expect that the listener to the Page.frameStoppedLoading event is removed 189 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 0L) 190 | hold(client$disconnect()) 191 | }) 192 | 193 | test_that("Event listener-With a predicate and a callback, the return object is a function that is used to remove the callback and returns the original callback function", { 194 | client <- hold(chrome$connect()) 195 | hold(client$Page$enable()) 196 | frame_id <- hold(client$Page$getFrameTree())$frameTree$frame$id 197 | result <- NULL 198 | witness <- client$Page$frameStoppedLoading(frameId = ~ .x == frame_id) %...>% { 199 | result <<- . 200 | } 201 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 202 | callback <- function(...) stop("this error should never fires") 203 | rm_callback <- client$Page$frameStoppedLoading(frameId = ~ .x == frame_id, callback = callback) 204 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 2L) 205 | returned_callback <- rm_callback() 206 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 207 | expect_identical(returned_callback, callback) 208 | client$Page$navigate(url = "http://httpbin.org/status/200") 209 | expect_silent(hold(witness)) 210 | expect_identical(result$frameId, frame_id) 211 | hold(client$disconnect()) 212 | }) 213 | 214 | test_that("Event listener-With a value as predicate, without callback, a promise is returned which is fulfilled when the predicate matches", { 215 | client <- hold(chrome$connect()) 216 | hold(client$Page$enable()) 217 | frame_id <- hold(client$Page$getFrameTree())$frameTree$frame$id 218 | pr <- client$Page$frameStoppedLoading(frameId = frame_id) 219 | # we expect that a listener is attached to Page.frameStoppedLoading event 220 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 221 | expect_is(pr, "promise") 222 | hold(client$Page$navigate(url = "http://httpbin.org/status/200")) 223 | res <- hold(pr) 224 | expect_identical(res$frameId, frame_id) 225 | # we expect that the listener to the Page.frameStoppedLoading event is removed 226 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 0L) 227 | hold(client$disconnect()) 228 | }) 229 | 230 | test_that("Event listener-With a value as predicate and a callback, the return object is a function that is used to remove the callback and returns the original callback function", { 231 | client <- hold(chrome$connect()) 232 | hold(client$Page$enable()) 233 | frame_id <- hold(client$Page$getFrameTree())$frameTree$frame$id 234 | result <- NULL 235 | witness <- client$Page$frameStoppedLoading(frameId = frame_id) %...>% { 236 | result <<- . 237 | } 238 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 239 | callback <- function(...) stop("this error should never fires") 240 | rm_callback <- client$Page$frameStoppedLoading(frameId = frame_id, callback = callback) 241 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 2L) 242 | returned_callback <- rm_callback() 243 | expect_identical(client$listenerCount("Page.frameStoppedLoading"), 1L) 244 | expect_identical(returned_callback, callback) 245 | client$Page$navigate(url = "http://httpbin.org/status/200") 246 | expect_silent(hold(witness)) 247 | expect_identical(result$frameId, frame_id) 248 | hold(client$disconnect()) 249 | }) 250 | -------------------------------------------------------------------------------- /R/CDPRemote.R: -------------------------------------------------------------------------------- 1 | #' @include utils.R 2 | #' @include http_methods.R 3 | #' @include CDPSession.R 4 | #' @include hold.R 5 | #' @importFrom assertthat assert_that is.scalar is.number 6 | NULL 7 | 8 | #' Declare a remote application implementing the Chrome Debugging Protocol 9 | #' 10 | #' This class aims to declare an application implementing the Chrome Debugging 11 | #' Protocol. It possesses methods to manage connections. 12 | #' 13 | #' @section Usage: 14 | #' ``` 15 | #' remote <- CDPRemote$new(host = "localhost", debug_port = 9222, secure = FALSE, 16 | #' local = FALSE, retry_delay = 0.2, max_attempts = 15L) 17 | #' 18 | #' remote$connect(callback = NULL) 19 | #' remote$listConnections() 20 | #' remote$closeConnections(callback = NULL) 21 | #' remote$version() 22 | #' remote$user_agent 23 | #' ``` 24 | #' 25 | #' @section Arguments: 26 | #' * `remote`: an object representing a remote application implementing the 27 | #' Chrome Debugging Protocol. 28 | #' * `host`: Character scalar, the host name of the application. 29 | #' * `debug_port`: Integer scalar, the remote debugging port. 30 | #' * `secure`: Logical scalar, indicating whether the https/wss protocols 31 | #' shall be used for connecting to the remote application. 32 | #' * `local`: Logical scalar, indicating whether the local version of the 33 | #' protocol (embedded in `crrri`) must be used or the protocol must be 34 | #' fetched _remotely_. 35 | #' * `retry_delay`: Number, delay in seconds between two successive tries to 36 | #' connect to the remote application. 37 | #' * `max_attempts`: Integer scalar, number of tries to connect to headless 38 | #' Chromium/Chrome. 39 | #' * `callback`: Function with one argument. 40 | #' 41 | #' @section Details: 42 | #' `$new()` declares a new remote application. 43 | #' 44 | #' `$connect(callback = NULL)` connects the R session to the remote application. 45 | #' The returned value depends on the value of the `callback` argument. When 46 | #' `callback` is a function, the returned value is a connection object. When 47 | #' `callback` is `NULL` the returned value is a promise which fulfills once R 48 | #' is connected to the remote application. Once fulfilled, the value of this 49 | #' promise is the connection object. 50 | #' 51 | #' `$listConnections()` returns a list of the connection objects succesfully 52 | #' created using the `$connect()` method. 53 | #' 54 | #' `$closeConnections(callback = NULL)` closes all the connections created using 55 | #' the `$connect()` method. If `callback` is `NULL`, it returns a promise which 56 | #' fulfills when all the connections are closed: once fulfilled, its value is the 57 | #' remote object. 58 | #' If `callback` is not `NULL`, it returns the remote object. In this case, 59 | #' `callback` is called when all the connections are closed and the remote object is 60 | #' passed to this function as the argument. 61 | #' 62 | #' `$version()` executes the DevTools `Version` method. It returns a list of 63 | #' informations available at `http://:/json/version`. 64 | #' 65 | #' `$user_agent` returns a character scalar with the User Agent of the 66 | #' remote application. 67 | #' 68 | #' `$listTargets()` returns a list with information about targets (or tabs). 69 | #' 70 | #' @name CDPRemote 71 | #' @examples 72 | #' \dontrun{ 73 | #' # Assuming that an application is already running at http://localhost:9222 74 | #' # For instance, you can execute: 75 | #' # chrome <- Chrome$new() 76 | #' 77 | #' remote <- CDPRemote$new() 78 | #' 79 | #' remote$connect() %...>% (function(client) { 80 | #' Page <- client$Page 81 | #' Runtime <- client$Runtime 82 | #' 83 | #' Page$enable() %...>% { 84 | #' Page$navigate(url = 'http://r-project.org') 85 | #' } %...>% { 86 | #' Page$loadEventFired() 87 | #' } %...>% { 88 | #' Runtime$evaluate( 89 | #' expression = 'document.documentElement.outerHTML' 90 | #' ) 91 | #' } %...>% (function(result) { 92 | #' cat(result$result$value, "\n") 93 | #' }) %...!% { 94 | #' cat("Error:", .$message, "\n") 95 | #' } %>% 96 | #' promises::finally(~ client$disconnect()) 97 | #' }) %...!% { 98 | #' cat("Error:", .$message, "\n") 99 | #' } 100 | #' } 101 | #' 102 | NULL 103 | 104 | #' @export 105 | CDPRemote <- R6::R6Class( 106 | "CDPRemote", 107 | public = list( 108 | initialize = function( 109 | host = "localhost", debug_port = 9222, secure = FALSE, local = FALSE, 110 | retry_delay = 0.2, max_attempts = 15L 111 | ) { 112 | assert_that(is_scalar_character(host)) 113 | assert_that(is.number(debug_port)) 114 | assert_that(is.scalar(secure), is.logical(secure)) 115 | assert_that(is.scalar(local), is.logical(local)) 116 | assert_that(is.number(retry_delay)) 117 | assert_that(is_scalar_integerish(max_attempts)) 118 | 119 | private$.port <- debug_port 120 | private$.secure <- secure 121 | private$.local_protocol <- isTRUE(local) 122 | private$.retry_delay <- retry_delay 123 | private$.max_attempts <- max_attempts 124 | remote_reachable <- is_remote_reachable(host, debug_port, secure, retry_delay, max_attempts) 125 | if(!remote_reachable && host == "localhost") { 126 | host <- "127.0.0.1" 127 | remote_reachable <- is_remote_reachable(host, debug_port, secure, retry_delay, max_attempts) 128 | } 129 | if(!remote_reachable) { 130 | warning("Cannot access to remote host...") 131 | private$.reachable <- FALSE 132 | } 133 | private$.host <- host 134 | self$version() # run once to store version 135 | }, 136 | connect = function(callback = NULL, .target_id = "default") { 137 | async <- is.null(callback) 138 | 139 | if(!is.null(callback)) { 140 | callback <- rlang::as_function(callback) 141 | assertthat::assert_that( 142 | length(rlang::fn_fmls(callback)) > 0, 143 | msg = "The callback function must have one argument." 144 | ) 145 | } 146 | private$.check_remote() 147 | if(!private$.reachable) { 148 | return(stop_or_reject( 149 | "Cannot access to remote host.", 150 | async = async 151 | )) 152 | } 153 | 154 | if(identical(.target_id, "default")) { 155 | # test if there is an available target 156 | if(length(self$listTargets()) == 0L) { 157 | return(self$connectToNewTab(callback = callback)) 158 | } 159 | ws_url <- chr_get_ws_addr(private$.host, private$.port, private$.secure) 160 | } else { 161 | targets <- self$listTargets() 162 | # extracts targets identifiers: 163 | ids <- purrr::map_chr(self$listTargets(), "id") 164 | # find the position of .target_id in this character vector 165 | pos <- purrr::detect_index(ids, ~ identical(.x, .target_id)) 166 | # if .target_id is not in the list, its position is 0 167 | if(pos == 0) { 168 | return(stop_or_reject( 169 | "unable to connect: wrong target ID.", 170 | async = async 171 | )) 172 | } 173 | # retrieve the websocket address associated with target_id: 174 | ws_url <- purrr::pluck(targets, pos, "webSocketDebuggerUrl") 175 | } 176 | 177 | con <- CDPSession( 178 | host = private$.host, 179 | port = private$.port, 180 | secure = private$.secure, 181 | ws_url = ws_url, 182 | local = private$.local_protocol, 183 | callback = callback 184 | ) 185 | if(promises::is.promise(con)) { 186 | promises::then( 187 | con, 188 | onFulfilled = function(value) { 189 | private$.clients <- c(private$.clients, list(value)) 190 | }, 191 | onRejected = function(err) { 192 | warning(err$message, call. = FALSE, immediate. = TRUE) 193 | } 194 | ) 195 | } else { 196 | private$.clients <- c(private$.clients, list(con)) 197 | } 198 | con 199 | }, 200 | listConnections = function() { 201 | private$.clients 202 | }, 203 | closeConnections = function(callback = NULL) { 204 | if(!is.null(callback)) { 205 | callback <- rlang::as_function(callback) 206 | } 207 | async <- is.null(callback) 208 | 209 | if(async) { 210 | # CDPSession disconnect() method returns a promise 211 | disconnected <- promises::promise_all( 212 | .list = purrr::map(private$.clients, function(client) { 213 | client$disconnect() 214 | }) 215 | ) 216 | # when connections are closed, remove them from the list of clients 217 | # and return the remote object (i.e. self) 218 | cleaned <- promises::then( 219 | disconnected, 220 | onFulfilled = function(value) { 221 | private$.clients <- list() 222 | invisible(self) 223 | } 224 | ) 225 | return(cleaned) 226 | } else { 227 | token <- new.env() 228 | token$done <- FALSE 229 | client_callback <- function(client) { 230 | if(private$.are_clients_closed() && !token$done) { 231 | private$.clients <- list() 232 | token$done <- TRUE 233 | callback(self) 234 | } 235 | } 236 | if(identical(length(private$.clients), 0L)) { 237 | on.exit(callback(self), add = TRUE) 238 | } 239 | purrr::walk(private$.clients, ~ .x$disconnect(callback = client_callback)) 240 | return(invisible(self)) 241 | } 242 | }, 243 | version = function() { 244 | private$.check_remote() 245 | if(private$.reachable) { 246 | # if remote is opened, update the private field .version 247 | private$.version <- fetch_version(private$.host, private$.port, private$.secure) 248 | } 249 | private$.version 250 | }, 251 | listTargets = function() { 252 | private$.check_remote() 253 | if(private$.reachable) { 254 | list_targets(private$.host, private$.port, private$.secure) 255 | } else { 256 | warning("cannot access to remote host.") 257 | } 258 | }, 259 | connectToNewTab = function(url = NULL, callback = NULL) { 260 | target <- new_tab(private$.host, private$.port, private$.secure, url) 261 | if(is.null(target$id)) { 262 | return( 263 | stop_or_reject( 264 | "Unable to create a new tab.", 265 | async = is.null(callback) 266 | ) 267 | ) 268 | } 269 | self$connect(callback = callback, .target_id = target$id) 270 | }, 271 | print = function() { 272 | version <- self$version() 273 | cat(sep = "", 274 | "<", version$Browser, ">\n", 275 | ' url: ', build_http_url(private$.host, private$.port, private$.secure), "\n", 276 | ' user-agent:\n', 277 | ' "', version$`User-Agent`, '"\n' 278 | ) 279 | } 280 | ), 281 | active = list( 282 | user_agent = function() { 283 | self$version()$`User-Agent` 284 | } 285 | ), 286 | private = list( 287 | .host = NULL, 288 | .port = NULL, 289 | .secure = FALSE, 290 | .local_protocol = FALSE, 291 | .retry_delay = 0.2, 292 | .max_attempts = 15L, 293 | .reachable = TRUE, 294 | .version = list(), 295 | .clients = list(), 296 | .check_remote = function() { 297 | if(private$.reachable) { 298 | private$.reachable <- is_remote_reachable( 299 | private$.host, 300 | private$.port, 301 | private$.secure, 302 | private$.retry_delay, 303 | private$.max_attempts 304 | ) 305 | } 306 | }, 307 | .are_clients_closed = function() { 308 | all(purrr::map_lgl(private$.clients, ~ .x$readyState() == 3L)) 309 | }, 310 | finalize = function() { 311 | # since we are in finalize, we can use hold() safely 312 | hold( 313 | self$closeConnections(), 314 | timeout = 10, 315 | msg = "The WebSocket connections have not been properly closed." 316 | ) 317 | } 318 | ) 319 | ) 320 | -------------------------------------------------------------------------------- /R/CDPSession.R: -------------------------------------------------------------------------------- 1 | #' @include EventEmitter.R 2 | #' @include domain.R 3 | #' @include CDProtocol.R 4 | #' @include utils.R 5 | #' @include hold.R 6 | #' @include http_methods.R 7 | #' @importFrom assertthat is.number 8 | NULL 9 | 10 | # Workaround an R CMD check false positive 11 | # See https://github.com/STAT545-UBC/Discussion/issues/451#issuecomment-264598618 12 | if(getRversion() >= "2.15.1") utils::globalVariables(c("private", "super", "self")) 13 | 14 | #' Connect to a remote instance implementing the Chrome Debugging Protocol 15 | #' 16 | #' This function creates a websocket connection to a remote instance using 17 | #' the Chrome Debugging Protocol. 18 | #' 19 | #' @inheritParams fetch_protocol 20 | #' @param ws_url Character scalar, the websocket URL. If provided, `host` and 21 | #' `port` arguments are ignored. 22 | #' @param callback Function with one argument, executed when the R session is 23 | #' connected to Chrome. The connection object is passed to this function. 24 | #' 25 | #' @return The returned value depends on the value of the `callback` argument. 26 | #' When `callback` is a function, the returned value is a connection object 27 | #' of class `CDPSession`. When `callback` is `NULL` the returned value is 28 | #' a promise which becomes fulfilled once R is connected to the remote 29 | #' instance. Once fulfilled, the value of this promise is the connection 30 | #' object of class `CDPSession`. 31 | #' 32 | #' @export 33 | CDPSession <- function( 34 | host = "localhost", port = 9222, secure = FALSE, ws_url = NULL, 35 | local = FALSE, callback = NULL 36 | ) { 37 | async <- is.null(callback) 38 | 39 | if(!is.null(ws_url)) { 40 | # check the format of ws_url 41 | if(!is_scalar_character(ws_url)) { 42 | return( 43 | stop_or_reject( 44 | "CDPSession() `ws_url` argument must be a character scalar.", 45 | async = async 46 | ) 47 | ) 48 | } 49 | # check the websocket address 50 | ws_url <- parse_ws_url(ws_url) # warning: ws_url is now a list of class `cdp_ws_url` or NULL 51 | if(is.null(ws_url)) { 52 | return( 53 | stop_or_reject( 54 | "the `ws_url` argument of CDPSession() is not a valid Chrome Degugging Protocol websocket address.", 55 | async = async 56 | ) 57 | ) 58 | } 59 | 60 | # change the protocol if required 61 | ws_url$secure <- secure 62 | 63 | # override host and port 64 | host <- ws_url$host 65 | port <- ws_url$port 66 | ws_url <- build_ws_url(ws_url) # warning: ws_url is now a character string 67 | } 68 | 69 | # check arguments 70 | if(!is_scalar_character(host)) { 71 | return( 72 | stop_or_reject( 73 | "CDPSession() `host` argument must be a character scalar.", 74 | async = async 75 | ) 76 | ) 77 | } 78 | if(!is.number(port) && !is_scalar_character(port)) { 79 | return( 80 | stop_or_reject( 81 | "CDPSession() `port` argument must be a numeric or a character scalar.", 82 | async = async 83 | ) 84 | ) 85 | } 86 | 87 | # check the remote application 88 | if(!is_remote_reachable(host, port, secure, max_attempts = 3L)) { 89 | return( 90 | stop_or_reject( 91 | paste0("Failed to connect to ", build_http_url(host, port, secure), "."), 92 | async = async 93 | ) 94 | ) 95 | } 96 | 97 | # retrieve the websocket address if not provided 98 | if(is.null(ws_url)) { 99 | ws_url <- chr_get_ws_addr(host = host, port = port, secure = secure) 100 | } 101 | # If there is no available target, ws_url is NULL, throw an error 102 | if(is.null(ws_url)) { 103 | return( 104 | stop_or_reject( 105 | paste0("No target available at ", build_http_url(host, port, secure), "."), 106 | async = async 107 | ) 108 | ) 109 | } 110 | # store the target type 111 | target_type <- parse_ws_url(ws_url)$type 112 | 113 | # get the protocol 114 | protocol <- CDProtocol$new(host = host, port = port, secure = secure, local = local) 115 | 116 | CDPSession <- R6::R6Class( 117 | "CDPSession", 118 | inherit = CDPConnexion, 119 | public = list( 120 | initialize = function(ws_url, protocol, autoConnect, onconnect, onerror) { 121 | super$initialize( 122 | ws_url = ws_url, 123 | autoConnect = FALSE, 124 | onconnect = onconnect, 125 | onerror = onerror 126 | ) 127 | self$.__protocol__ <- protocol 128 | for (name in protocol$domains) { 129 | self[[name]] <- domain(self, name) 130 | } 131 | if(isTRUE(autoConnect)) { 132 | private$.connect() 133 | } 134 | }, 135 | .__protocol__ = NULL 136 | ) 137 | ) 138 | # add domain method into the R6 object 139 | for (domain in protocol$domains) { 140 | CDPSession$set("public", domain, NULL) 141 | } 142 | # if the target is a page, add methods inspect(), activateTab() and closeTab() 143 | # these methods are added dynamically because they are irrelevant for the "browser" websocket endpoint 144 | if(identical(target_type, "page")) { 145 | CDPSession$set("public", "inspect", function() { 146 | if(self$readyState() == 1L) { 147 | inspect_target(private$.host, private$.port, private$.secure, private$.target_id) 148 | } else { 149 | warning( 150 | "Invalid connection state. Cannot open target in a web browser.", 151 | call. = FALSE, immediate. = TRUE 152 | ) 153 | } 154 | }) 155 | 156 | CDPSession$set("public", "activateTab", function() { 157 | if(self$readyState() == 1L) { 158 | return(promises::promise_resolve( 159 | activate_target(private$.host, private$.port, private$.secure, private$.target_id) 160 | )) 161 | } 162 | promises::promise_reject( 163 | "Invalid connection state. Cannot open target in a web browser." 164 | ) 165 | }) 166 | 167 | CDPSession$set("public", "closeTab", function() { 168 | promises::then( 169 | self$disconnect(), 170 | onFulfilled = ~ close_target(target_id = private$.target_id) 171 | ) 172 | }) 173 | } 174 | 175 | if(async) { 176 | onconnect <- NULL 177 | onerror <- NULL 178 | pr <- promises::promise(function(resolve, reject) { 179 | onconnect <<- resolve 180 | onerror <<- reject 181 | }) 182 | } else { 183 | onconnect <- rlang::as_function(callback) 184 | onerror <- stop 185 | } 186 | client <- CDPSession$new( 187 | ws_url = ws_url, 188 | protocol = protocol, 189 | autoConnect = TRUE, 190 | onconnect = onconnect, 191 | onerror = onerror 192 | ) 193 | if(async) return(pr) 194 | client 195 | } 196 | 197 | CDPConnexion <- R6::R6Class( 198 | "CDPConnexion", 199 | inherit = EventEmitter, 200 | public = list( 201 | initialize = function(ws_url, autoConnect = FALSE, onconnect = NULL, onerror = NULL) { 202 | "!DEBUG Configuring the websocket connexion..." 203 | ws <- websocket::WebSocket$new(ws_url, autoConnect = FALSE) 204 | ws_url <- parse_ws_url(ws_url) 205 | private$.host <- ws_url$host 206 | private$.port <- ws_url$port 207 | private$.secure <- ws_url$secure 208 | private$.target_type <- ws_url$type 209 | private$.target_id <- ws_url$id 210 | 211 | ws$onOpen(function(event) { 212 | self$emit("connect", self) 213 | "!DEBUG ...R succesfully connected to headless Chrome through DevTools Protocol." 214 | }) 215 | ws$onMessage(function(event) { 216 | "!DEBUG Got message from Chrome: `event$data`" 217 | data <- from_json(event$data) 218 | id <- data$id 219 | method <- data$method 220 | # if error, emit an error 221 | if (!is.null(data$error)) { 222 | "!DEBUG error: `event$data`" 223 | self$emit("error", simpleError(paste0(data$error$message, ". code: ", data$error$code))) 224 | } 225 | # if a reponse to a command, emit a response event 226 | if (!is.null(id)) { 227 | self$emit("response", id = data$id, result = data$result) 228 | } 229 | # if an event is fired, emit the corresponding listeners 230 | if (!is.null(method)) { 231 | self$emit(method, data$params) 232 | } 233 | }) 234 | ws$onClose(function(event) { 235 | "!DEBUG R disconnected from headless Chrome with code `event$code`" 236 | "!DEBUG and reason `event$reason`." 237 | self$emit("disconnect", self) 238 | }) 239 | ws$onError(function(event) { 240 | "!DEBUG Client failed to connect: `event$message`." 241 | # TODO use simpleError(event$message) 242 | self$emit("error", simpleError(event$message)) 243 | }) 244 | super$on("ready", function() { 245 | private$.ready <- TRUE 246 | }) 247 | super$on("command_will_be_sent", function(msg) { 248 | private$.ready <- FALSE 249 | }) 250 | super$once("connect", function(client) { 251 | self$emit("ready") 252 | }) 253 | rm_onerror <- NULL 254 | rm_onconnect <- NULL 255 | if(!is.null(onconnect)) { 256 | rm_onconnect <- super$once("connect", function(client) { 257 | if(!is.null(rm_onerror)) rm_onerror() 258 | onconnect(client) 259 | }) 260 | } 261 | if(!is.null(onerror)) { 262 | rm_onerror <- super$once("error", function(err) { 263 | if(!is.null(rm_onconnect)) rm_onconnect() 264 | onerror(err) 265 | }) 266 | } 267 | # when the command event is emitted, send a command to Chrome 268 | super$on("command", function(id = 1L, method, params = NULL, onresponse, onerror = NULL) { 269 | if(missing(id)) { 270 | # increment id 271 | self$id <- 1L 272 | id <- self$id 273 | } 274 | msg <- private$.buildMessage(id = id, method = method, params = params) 275 | id_sent <- id 276 | 277 | rm_onresponse <- NULL 278 | rm_onerror <- NULL 279 | onresponse <- rlang::as_function(onresponse) 280 | rm_onresponse <- super$on("response", function(id, result) { 281 | if(id == id_sent) { 282 | rm_onresponse() 283 | if(!is.null(rm_onerror)) rm_onerror() 284 | onresponse(result) 285 | } 286 | }) 287 | 288 | if(!is.null(onerror)) { 289 | onerror <- rlang::as_function(onerror) 290 | rm_onerror <- super$once("error", function(err) { 291 | rm_onresponse() 292 | rm_onerror() 293 | onerror(err) 294 | }) 295 | } 296 | self$emit("command_will_be_sent", msg) 297 | private$.commandList[[as.character(id)]] <- list(method = method, params = params) 298 | private$.CDPSession_con$send(msg) 299 | "!DEBUG Command #`id`-`method` sent." 300 | }) 301 | # when a response event is fired, emit an event corresponding to the sent command 302 | super$on("response", function(id, result) { 303 | method_sent <- private$.commandList[[as.character(id)]]$method 304 | private$.commandList[[as.character(id)]] <- NULL 305 | self$emit(method_sent, result) 306 | if(length(private$.commandList) == 0) { 307 | self$emit("ready") 308 | } 309 | }) 310 | "!DEBUG ...websocket connexion configured." 311 | private$.CDPSession_con <- ws 312 | if(isTRUE(autoConnect)) { 313 | ws$connect() 314 | } 315 | }, 316 | send = function(method, params = NULL, onresponse = NULL, onerror = NULL, ...) { 317 | if(async <- is.null(onresponse)) { 318 | pr <- promises::promise(function(resolve, reject) { 319 | onresponse <<- resolve 320 | onerror <<- reject 321 | }) 322 | } else { 323 | onresponse <- rlang::as_function(onresponse) 324 | } 325 | if(!is.null(onerror)) { 326 | onerror <- rlang::as_function(onerror) 327 | } 328 | id <- list(...)$id 329 | if(is.null(id)) { 330 | self$emit("command", method = method, params = params, onresponse = onresponse, onerror = onerror) 331 | } else { 332 | self$emit("command", id = id, method = method, params = params, onresponse = onresponse, onerror = onerror) 333 | } 334 | if(async) return(pr) 335 | invisible(self) 336 | }, 337 | on = function(eventName, callback = NULL) { 338 | if(is.null(callback)) { 339 | return(self$once(eventName)) 340 | } else { 341 | callback <- rlang::as_function(callback) 342 | } 343 | super$on(eventName, callback) 344 | }, 345 | once = function(eventName, callback = NULL) { 346 | if(is.null(callback)) { 347 | onerror <- NULL 348 | rm_onerror <- NULL 349 | rm_onsuccess <- NULL 350 | pr <- promises::promise(function(resolve, reject) { 351 | onerror <<- reject 352 | callback <<- function(...) { 353 | rm_onerror() 354 | result <- list(...) 355 | resolve(result) 356 | } 357 | }) 358 | rm_onsuccess <- super$once(eventName, callback) 359 | rm_onerror <- super$once("error", function(err) { 360 | rm_onsuccess() 361 | onerror(err) 362 | }) 363 | return(pr) 364 | } else { 365 | callback <- rlang::as_function(callback) 366 | } 367 | super$once(eventName, callback) 368 | }, 369 | readyState = function() { 370 | private$.CDPSession_con$readyState() 371 | }, 372 | disconnect = function(callback = NULL) { 373 | # Variables initialization 374 | pr <- NULL 375 | onerror <- NULL 376 | rm_onerror <- NULL 377 | rm_onsuccess <- NULL 378 | if(async <- is.null(callback)) { 379 | pr <- promises::promise(function(resolve, reject) { 380 | onerror <<- reject 381 | callback <<- resolve 382 | }) 383 | } else { 384 | onerror <- stop 385 | } 386 | callback <- rlang::as_function(callback) # in case of a user-supplied rlang lambda function 387 | 388 | # if the connection is already closed, the `disconnect` event will never fire 389 | if(self$readyState() == 3L) { 390 | on.exit(do.call(callback, list(self)), add = TRUE) 391 | if(async) { 392 | return(pr) 393 | } else { 394 | return(invisible(self)) 395 | } 396 | } 397 | 398 | # here, we know that the connection is not closed 399 | # the `disconnect` event will fire. 400 | rm_onsuccess <- super$once("disconnect", listener = function(client) { 401 | rm_onerror() 402 | callback(client) 403 | }) 404 | rm_onerror <- super$once("error", listener = function(err) { 405 | rm_onsuccess() 406 | onerror(err$message) 407 | }) 408 | 409 | # If the connection is not closing, send the close command: 410 | if(self$readyState() < 2L) { 411 | on.exit(private$.CDPSession_con$close(), add = TRUE) 412 | } 413 | 414 | if(async) { 415 | return(pr) 416 | } 417 | invisible(self) 418 | }, 419 | print = function() { 420 | domains <- self$.__protocol__$domains 421 | describe <- function(domain) { 422 | experimental <- self$.__protocol__$is_domain_experimental(domain) 423 | experimental <- if(experimental) " (experimental)" else "" 424 | desc <- self$.__protocol__$domain_description(domain) 425 | desc <- gsub("\n", " ", desc) 426 | sep <- if(nzchar(desc)) ": " else "" 427 | paste0(experimental, sep, desc) 428 | } 429 | domains_desc <- purrr::map_chr(domains, describe) 430 | domains_info <- paste0(domains, domains_desc, "\n") 431 | cat(sep = "\n", 432 | '', 433 | paste0('connected to: ', build_http_url(private$.host, private$.port, private$.secure)), 434 | paste0(' target type: "', private$.target_type, '"'), 435 | paste0(' target ID: "', private$.target_id, '"'), 436 | '', 437 | "", 438 | domains_info 439 | ) 440 | invisible(self) 441 | } 442 | ), 443 | active = list( 444 | # Value assigned increment id 445 | id = function(value) { 446 | if (missing(value)) return(private$.lastID) 447 | if (is.null(value)) { 448 | private$.lastID <- 1L 449 | } else { 450 | private$.lastID <- private$.lastID + value 451 | } 452 | private$.lastID 453 | } 454 | ), 455 | private = list( 456 | .host = NULL, 457 | .port = NULL, 458 | .secure = NULL, 459 | .target_type = NULL, 460 | .target_id = NULL, 461 | .CDPSession_con = list(), 462 | .lastID = 0L, 463 | .buildMessage = function(id, method, params = NULL) { 464 | data <- list(id = id, method = method) 465 | if(!is.null(params)) 466 | data <- c(data, list(params = params)) 467 | jsonlite::toJSON(data, auto_unbox = TRUE) 468 | }, 469 | .commandList = list(), 470 | .ready = FALSE, 471 | .connect = function() { 472 | private$.CDPSession_con$connect() 473 | }, 474 | finalize = function() { 475 | if (self$readyState() < 2L) { 476 | hold(self$disconnect()) 477 | message("WebSocket connection closed.") 478 | } 479 | } 480 | ) 481 | ) 482 | 483 | chr_get_ws_addr <- function(host = "localhost", port = 9222, secure = FALSE) { 484 | "!DEBUG Retrieving Chrome websocket entrypoint at http://localhost:`port`/json ..." 485 | targets <- list_targets(host, port, secure) 486 | active_target <- purrr::detect(targets, ~ identical(.x$type, "page")) 487 | address <- active_target$webSocketDebuggerUrl 488 | if (is.null(address)) 489 | "!DEBUG ...websocket entrypoint unavailable." 490 | else 491 | "!DEBUG ...found websocket entrypoint `address`" 492 | 493 | if(isTRUE(secure)) { 494 | address <- httr::modify_url(address, scheme = "wss") 495 | } 496 | address # NULL when fails 497 | } 498 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r setup, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | eval = FALSE, 11 | comment = "#>", 12 | fig.path = "man/figures/README-", 13 | out.width = "100%" 14 | ) 15 | Sys.unsetenv("DEBUGME") 16 | ``` 17 | # crrri 18 | 19 | 20 | [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 21 | [![Codecov test coverage](https://codecov.io/gh/RLesur/crrri/branch/master/graph/badge.svg)](https://codecov.io/gh/RLesur/crrri?branch=master) 22 | [![CRAN status](https://www.r-pkg.org/badges/version/crrri)](https://cran.r-project.org/package=crrri) 23 | [![R build status](https://github.com/RLesur/crrri/workflows/R-CMD-check/badge.svg)](https://github.com/RLesur/crrri/actions) 24 | 25 | 26 | **Work in progress** 27 | 28 | The goal of `crrri` is to provide a native Chrome Remote Interface in R using the [Chrome Debugging Protocol](https://chromedevtools.github.io/devtools-protocol/). This is a low-level implementation of the protocol heavily inspired by the [`chrome-remote-interface`](https://github.com/cyrus-and/chrome-remote-interface) JavaScript library written by [Andrea Cardaci](https://github.com/cyrus-and). 29 | 30 | This package is intended to R packages developers who need to orchestrate Chromium/Chrome: **with `crrri`, you can easily interact with (headless) Chromium/Chrome using R**. We worked a lot to provide the most simple API. However, you will have the bulk of the work and learn how the Chrome DevTools Protocol works. Interacting with Chromium/Chrome using the DevTools Protocol is a highly technical task and prone to errors: you will be close to the metal and have full power (be cautious!). 31 | 32 | This package is built on top of the [`websocket`](https://github.com/rstudio/websocket) and [`promises`](https://cran.r-project.org/package=promises) packages. The default design of the `crrri` functions is asynchronous: they return promises. You can also use `crrri` with callbacks if you prefer. 33 | 34 | We are highly indebted to [Miles McBain](https://github.com/milesmcbain) for his seminal work on [`chradle`](https://github.com/milesmcbain/chradle) that inspired us. Many thanks! 35 | 36 | ## System requirements 37 | 38 | First of all, you **do not need a `node.js` configuration** because **`crrri` is 39 | fully written in R**. 40 | 41 | You only need a recent version of Chromium or Chrome. A standalone version works perfectly well on Windows. By default, `crrri` will try to find a chrome binary on your system to use, using the `find_chrome_binary()`. You can tell `crrri` to use a specific version by setting the value of the `HEADLESS_CHROME` environment variable to the path of Chromium or Chrome (this is the same environment variable that is used in [`decapitated`](https://github.com/hrbrmstr/decapitated)). You can check it is set correctly by executing `Sys.getenv("HEADLESS_CHROME")` in your R console. 42 | 43 | Otherwise, you can also use the `bin` argument of the `Chrome` class `new()` method to provide the path directly. 44 | ```r 45 | chrome <- Chrome$new(bin = "") 46 | ``` 47 | 48 | Note that if ever you don't know where your binary is, you can use directly the `find_chrome_binary()` function, which will try to guess where your binary is (you might neeed to install the package). 49 | 50 | This two calls are equivalent 51 | 52 | ```r 53 | chrome <- Chrome$new(bin = find_chrome_binary()) 54 | # the default 55 | chrome <- Chrome$new(bin = NULL) 56 | ``` 57 | 58 | ## Installation 59 | 60 | You can install the development version of `crrri` from GitHub with: 61 | 62 | ```{r, eval=FALSE} 63 | remotes::install_github('rlesur/crrri') 64 | ``` 65 | ## Using `crrri` interactively 66 | 67 | The `crrri` package is a low-level interface and **is not intended to be used interactively**: the goal of `crrri` is to provide to R developers a set of classes and helper functions to build higher levels functions. 68 | 69 | **However, you can discover headless Chrome automation interactively in your R session using `crrri`**. This will help you to learn the [Chrome DevTools Protocol](https://chromedevtools.github.io/devtools-protocol), the `crrri` design and develop higher level functions. 70 | 71 | ### A short-tour 72 | 73 | Assuming that you have configured the `HEADLESS_CHROME` environment variable (see [above](#system-requirements)), you can start headless Chrome: 74 | 75 | ```{r} 76 | library(crrri) 77 | chrome <- Chrome$new() 78 | ``` 79 | 80 | The `Chrome` class constructor is a **synchronous function**. That means the R session is on hold until the command terminates. 81 | 82 | The `$connect()` method of the `Chrome` class will connect the R session to headless Chrome. As the connection process can take some time, the R session does not hold^[most of R users should think that this behavior is weird but it is extremely powerful!]: this is an **asynchronous function**. This function returns a promise which is fulfilled when R is connected to Chrome. 83 | 84 | However, you can pass a callback function to the `$connect()` method using its `callback` argument. In this case, the returned object will be a connection object: 85 | 86 | ```{r} 87 | client <- chrome$connect(callback = function(client) { 88 | client$inspect() 89 | }) 90 | ``` 91 | 92 | The `$inspect()` method of the connection object opens the Chrome DevTools Inspector in RStudio (>= 1.2.1335) or in your default web browser (you can have some trouble if the inspector is not opened in Chromium/Chrome). It is convenient if you need to inspect the content of a web page because all that you need is in RStudio. 93 | 94 | ![DevTools Inspector in RStudio viewer](https://user-images.githubusercontent.com/19177171/56867255-861c3900-69e3-11e9-88cd-2ef29075070f.png) 95 | 96 | In order to discover the [Chrome DevTools Protocol](https://chromedevtools.github.io/devtools-protocol) commands and events listeners, it is recommended to extract one of the domains^[a domain is a set of commands, events listeners and types.] from the connection object: 97 | 98 | ```{r} 99 | Page <- client$Page 100 | ``` 101 | 102 | The `Page` object represents the [`Page` domain](https://chromedevtools.github.io/devtools-protocol/tot/Page). It possesses methods to send commands or listen to specific events. 103 | 104 | For instance, you can send to Chromium/Chrome the [`Page.navigate`](https://chromedevtools.github.io/devtools-protocol/tot/Page#method-navigate) command as follows: 105 | 106 | ```{r} 107 | Page$navigate(url = "http://r-project.org") 108 | ``` 109 | Once the page is loaded by headless Chrome, RStudio looks like this: 110 | 111 | ![R Project website in headless Chrome](https://user-images.githubusercontent.com/19177171/56867262-8f0d0a80-69e3-11e9-828f-4dddb0bcd492.png) 112 | 113 | You will see in the R console: 114 | 115 | ``` 116 | 117 | ``` 118 | 119 | This is a promise object that is fulfilled when Chromium/Chrome sends back to R a message telling that the command was well-received. This comes from the fact that the `Page$navigate()` function is also asynchronous. All the asynchronous methods possess a `callback` argument. When the R session receives the result of the command from Chrome, R executes this callback function passing the result object to this function. For instance, you can execute: 120 | 121 | ```{r} 122 | Page$navigate(url = "https://ropensci.org/", callback = function(result) { 123 | cat("The R session has received this result from Chrome!\n") 124 | print(result) 125 | }) 126 | ``` 127 | 128 | Once the page is loaded, you will see both the web page and the result object object in RStudio: 129 | 130 | ![rOpenSci website in headless Chrome](https://user-images.githubusercontent.com/19177171/56867269-9cc29000-69e3-11e9-8fa4-ca238d3b3566.png) 131 | 132 | To inspect the result of a command you can pass the `print` function to the `callback` argument: 133 | 134 | ```{r} 135 | Page$navigate(url = "https://ropensci.org/", callback = print) 136 | ``` 137 | 138 | ``` 139 | #> $frameId 140 | #> [1] "3BB38B10082F28A946332100964486EC" 141 | #> 142 | #> $loaderId 143 | #> [1] "9DCF07625678433563CB03FFF1E8A6AB" 144 | ``` 145 | The result object sent back from Chrome is also the value of the promises once fulfilled. Recall that if you do not use a callback function, you get a promise: 146 | 147 | ```{r} 148 | async_result <- Page$navigate(url = "http://r-project.org") 149 | ``` 150 | 151 | You can print the value of this promise once fulfilled with: 152 | 153 | ```{r} 154 | async_result %...>% print() 155 | ``` 156 | 157 | ``` 158 | #> $frameId 159 | #> [1] "3BB38B10082F28A946332100964486EC" 160 | #> 161 | #> $loaderId 162 | #> [1] "7B2383E8F2F39273E18E4D918F1852A0" 163 | ``` 164 | 165 | As you can see, this leads to the same result as with a callback function. 166 | 167 | To sum up, these two forms perform the same actions: 168 | 169 | ```{r} 170 | Page$navigate(url = "http://r-project.org", callback = print) 171 | Page$navigate(url = "http://r-project.org") %...>% print() 172 | ``` 173 | 174 | If you interact with headless Chrome in the R console using `crrri`, these two forms are equivalent. 175 | **However, if you want to use `crrri` to develop higher level functions, the most reliable way is to use promises.** 176 | 177 | Do not forget to close headless Chrome with: 178 | 179 | ```{r} 180 | chrome$close() 181 | ``` 182 | 183 | Since the RStudio viewer has lost the connection, you will see this screen in RStudio: 184 | 185 | ![headless Chrome closed](https://user-images.githubusercontent.com/19177171/56867276-a4823480-69e3-11e9-8530-831ac4dd144e.png) 186 | 187 | Now, you can take some time to discover all the commands and events of the [Chrome DevTools Protocol](https://chromedevtools.github.io/devtools-protocol/). The following examples will introduce some of them. 188 | 189 | ### Domains, commands and events listeners 190 | 191 | While working interactively, you can obtain the list of available domains in your version of Chromium/Chrome. 192 | First, launch Chromium/Chrome and connect the R session to headless Chromium/Chrome: 193 | 194 | ```r 195 | chrome <- Chrome$new() 196 | client <- chrome$connect(~ .x$inspect()) 197 | ``` 198 | 199 | Once connected, you just have to print the connection object to get informations about the connection and availables domains: 200 | 201 | ```r 202 | client 203 | ``` 204 | 205 | ``` 206 | #> 207 | #> connected to: http://localhost:9222/ 208 | #> target type: "page" 209 | #> target ID: "9A576420CADEA9A514C5F027D30B410D" 210 | #> 211 | #> 212 | #> Accessibility (experimental) 213 | #> 214 | #> Animation (experimental) 215 | #> 216 | #> ApplicationCache (experimental) 217 | #> 218 | #> Audits (experimental): Audits domain allows investigation of page violations and possible improvements. 219 | #> 220 | #> Browser: The Browser domain defines methods and events for browser managing. 221 | #> 222 | #> CacheStorage (experimental) 223 | #> 224 | #> Cast (experimental): A domain for interacting with Cast, Presentation API, and Remote Playback API functionalities. 225 | ... 226 | ``` 227 | 228 | These informations are directly retrieved from Chromium/Chrome: you may obtain different informations depending on the Chromium/Chrome version. 229 | 230 | In the most recent versions of the Chrome DevTools Protocol, more than 40 domains are available. A domain is a set of commands and events listeners. 231 | 232 | In order to work with a domain, it is recommended to extract it from the connection object. For instance, if you want to access to the `Runtime` domain, execute: 233 | 234 | ```r 235 | Runtime <- client$Runtime 236 | ``` 237 | 238 | If you print this object, this will open the online documentation about this domain in your browser: 239 | 240 | ```r 241 | Runtime # opens the online documentation in a browser 242 | ``` 243 | 244 | ## Presentations about crrri 245 | 246 | * **uros2019** - 20/05/2019 ([slides](https://speakerdeck.com/rlesur/headless-chrome-automation-with-r-the-crrri-package)) 247 | * **useR!2019** - 12/07/2019 ([slides](https://cderv.gitlab.io/user2019-crrri/)) 248 | 249 | ## Examples 250 | 251 | ### Generate a PDF 252 | 253 | Here is an example that produces a PDF of the [R Project website](https://www.r-project.org/): 254 | 255 | ```{r, results='hide'} 256 | library(promises) 257 | library(crrri) 258 | library(jsonlite) 259 | 260 | perform_with_chrome(function(client) { 261 | Page <- client$Page 262 | 263 | Page$enable() %...>% { # await enablement of the Page domain 264 | Page$navigate(url = "https://www.r-project.org/") 265 | Page$loadEventFired() # await the load event 266 | } %...>% { 267 | Page$printToPDF() 268 | } %...>% { # await PDF reception 269 | .$data %>% base64_dec() %>% writeBin("r_project.pdf") 270 | } 271 | }) 272 | ``` 273 | 274 | All the functions of the `crrri` package (commands and event listeners) return promises (as defined in the **promises** package) by default. When building higher level functions, do not forget that you have to deal with promises (those will prevent you to fall into the _Callback Hell_). 275 | 276 | For instance, you can write a `save_as_pdf` function as follow: 277 | 278 | ```{r} 279 | save_url_as_pdf <- function(url) { 280 | function(client) { 281 | Page <- client$Page 282 | 283 | Page$enable() %...>% { 284 | Page$navigate(url = url) 285 | Page$loadEventFired() 286 | } %...>% { 287 | Page$printToPDF() 288 | } %...>% { 289 | .$data %>% 290 | jsonlite::base64_dec() %>% 291 | writeBin(paste0(httr::parse_url(url)$hostname, ".pdf")) 292 | } 293 | } 294 | } 295 | ``` 296 | 297 | You can pass several functions to `perform_with_chrome()`: 298 | 299 | ```{r} 300 | save_as_pdf <- function(...) { 301 | list(...) %>% 302 | purrr::map(save_url_as_pdf) %>% 303 | perform_with_chrome(.list = .) 304 | } 305 | ``` 306 | 307 | You have created a `save_as_pdf()` function that can handle multiple URLs: 308 | 309 | ```{r} 310 | save_as_pdf("http://r-project.org", "https://ropensci.org/", "https://rstudio.com") 311 | ``` 312 | 313 | ### Transpose `chrome-remote-interface` JS scripts: dump the DOM 314 | 315 | With `crrri`, you should be able to transpose with minimal efforts some JS scripts written with the [`chrome-remote-interface`](https://github.com/cyrus-and/chrome-remote-interface) node.js module. 316 | 317 | For instance, take [this JS script](https://github.com/cyrus-and/chrome-remote-interface/wiki/Dump-HTML-after-page-load) that dumps the DOM: 318 | 319 | ```js 320 | const CDP = require('chrome-remote-interface'); 321 | 322 | CDP(async(client) => { 323 | const {Network, Page, Runtime} = client; 324 | try { 325 | await Network.enable(); 326 | await Page.enable(); 327 | await Network.setCacheDisabled({cacheDisabled: true}); 328 | await Page.navigate({url: 'https://github.com'}); 329 | await Page.loadEventFired(); 330 | const result = await Runtime.evaluate({ 331 | expression: 'document.documentElement.outerHTML' 332 | }); 333 | const html = result.result.value; 334 | console.log(html); 335 | } catch (err) { 336 | console.error(err); 337 | } finally { 338 | client.close(); 339 | } 340 | }).on('error', (err) => { 341 | console.error(err); 342 | }); 343 | ``` 344 | 345 | Using `crrri`, you can write: 346 | 347 | ```{r, results='hide'} 348 | library(promises) 349 | library(crrri) 350 | 351 | async_dump_DOM <- function(client) { 352 | Network <- client$Network 353 | Page <- client$Page 354 | Runtime <- client$Runtime 355 | Network$enable() %...>% { 356 | Page$enable() 357 | } %...>% { 358 | Network$setCacheDisabled(cacheDisabled = TRUE) 359 | } %...>% { 360 | Page$navigate(url = 'https://github.com') 361 | } %...>% { 362 | Page$loadEventFired() 363 | } %...>% { 364 | Runtime$evaluate( 365 | expression = 'document.documentElement.outerHTML' 366 | ) 367 | } %...>% (function(result) { 368 | html <- result$result$value 369 | cat(html, "\n") 370 | }) 371 | } 372 | 373 | perform_with_chrome(async_dump_DOM) 374 | ``` 375 | 376 | If you want to write a higher level function that dump the DOM, you can embed the main part of this script in a function: 377 | 378 | ```{r} 379 | dump_DOM <- function(url) { 380 | perform_with_chrome(function(client) { 381 | Network <- client$Network 382 | Page <- client$Page 383 | Runtime <- client$Runtime 384 | Network$enable() %...>% { 385 | Page$enable() 386 | } %...>% { 387 | Network$setCacheDisabled(cacheDisabled = TRUE) 388 | } %...>% { 389 | Page$navigate(url = url) 390 | } %...>% { 391 | Page$loadEventFired() 392 | } %...>% { 393 | Runtime$evaluate( 394 | expression = 'document.documentElement.outerHTML' 395 | ) 396 | } %...>% (function(result) { 397 | html <- result$result$value 398 | cat(html, "\n") 399 | }) 400 | }) 401 | } 402 | ``` 403 | 404 | Now, you can use it for dumping [David Gohel](https://github.com/davidgohel)'s [blog](http://www.ardata.fr/blog/): 405 | 406 | ```{r, results='hide'} 407 | dumpDOM(url = "http://www.ardata.fr/blog/") 408 | ``` 409 | 410 | You can find many other examples in the [wiki](https://github.com/cyrus-and/chrome-remote-interface/wiki) of the `chrome-remote-interface` module. 411 | 412 | 413 | ## Development 414 | 415 | ### Logging Messages 416 | 417 | In `crrri`, there are two types of messages: 418 | 419 | - Those sent during connection/disconnection (mainly for crrri debugging) 420 | - Those tracking the exchanges between the R websocket client and the remote 421 | websocket server. These lasts are essential for R devs to develop higher levels 422 | packages, either during the development process and for debugging purposes. 423 | 424 | `crrri` uses [`debugme`](https://github.com/r-lib/debugme) for printing those 425 | messages. It is disable by default and you won't see any messages - as a user we 426 | think it is fine. However, if you are a developer, you would expect some 427 | information on what is going on. 428 | 429 | You need to add `"crrri"` to the `DEBUGME` environment variable before loading 430 | the package to activate the messaging feature. Currently in `crrri` there is 431 | only one level of message.Also, `debugme` is a Suggested dependency and you may 432 | need to install it manually if not already installed. 433 | 434 | ## Credits 435 | 436 | Andrea Cardaci for `chrome-remote-interface`. 437 | 438 | Miles McBain for `chradle`. 439 | 440 | Bob Rudis for `decapitated`. 441 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # crrri 5 | 6 | 7 | 8 | [![Lifecycle: 9 | experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 10 | [![Codecov test 11 | coverage](https://codecov.io/gh/RLesur/crrri/branch/master/graph/badge.svg)](https://codecov.io/gh/RLesur/crrri?branch=master) 12 | [![CRAN 13 | status](https://www.r-pkg.org/badges/version/crrri)](https://cran.r-project.org/package=crrri) 14 | [![R build 15 | status](https://github.com/RLesur/crrri/workflows/R-CMD-check/badge.svg)](https://github.com/RLesur/crrri/actions) 16 | 17 | 18 | **Work in progress** 19 | 20 | The goal of `crrri` is to provide a native Chrome Remote Interface in R 21 | using the [Chrome Debugging 22 | Protocol](https://chromedevtools.github.io/devtools-protocol/). This is 23 | a low-level implementation of the protocol heavily inspired by the 24 | [`chrome-remote-interface`](https://github.com/cyrus-and/chrome-remote-interface) 25 | JavaScript library written by [Andrea 26 | Cardaci](https://github.com/cyrus-and). 27 | 28 | This package is intended to R packages developers who need to 29 | orchestrate Chromium/Chrome: **with `crrri`, you can easily interact 30 | with (headless) Chromium/Chrome using R**. We worked a lot to provide 31 | the most simple API. However, you will have the bulk of the work and 32 | learn how the Chrome DevTools Protocol works. Interacting with 33 | Chromium/Chrome using the DevTools Protocol is a highly technical task 34 | and prone to errors: you will be close to the metal and have full power 35 | (be cautious\!). 36 | 37 | This package is built on top of the 38 | [`websocket`](https://github.com/rstudio/websocket) and 39 | [`promises`](https://cran.r-project.org/package=promises) packages. The 40 | default design of the `crrri` functions is asynchronous: they return 41 | promises. You can also use `crrri` with callbacks if you prefer. 42 | 43 | We are highly indebted to [Miles McBain](https://github.com/milesmcbain) 44 | for his seminal work on 45 | [`chradle`](https://github.com/milesmcbain/chradle) that inspired us. 46 | Many thanks\! 47 | 48 | ## System requirements 49 | 50 | First of all, you **do not need a `node.js` configuration** because 51 | **`crrri` is fully written in R**. 52 | 53 | You only need a recent version of Chromium or Chrome. A standalone 54 | version works perfectly well on Windows. By default, `crrri` will try to 55 | find a chrome binary on your system to use, using the 56 | `find_chrome_binary()`. You can tell `crrri` to use a specific version 57 | by setting the value of the `HEADLESS_CHROME` environment variable to 58 | the path of Chromium or Chrome (this is the same environment variable 59 | that is used in 60 | [`decapitated`](https://github.com/hrbrmstr/decapitated)). You can check 61 | it is set correctly by executing `Sys.getenv("HEADLESS_CHROME")` in your 62 | R console. 63 | 64 | Otherwise, you can also use the `bin` argument of the `Chrome` class 65 | `new()` method to provide the path directly. 66 | 67 | ``` r 68 | chrome <- Chrome$new(bin = "") 69 | ``` 70 | 71 | Note that if ever you don’t know where your binary is, you can use 72 | directly the `find_chrome_binary()` function, which will try to guess 73 | where your binary is (you might neeed to install the package). 74 | 75 | This two calls are equivalent 76 | 77 | ``` r 78 | chrome <- Chrome$new(bin = find_chrome_binary()) 79 | # the default 80 | chrome <- Chrome$new(bin = NULL) 81 | ``` 82 | 83 | ## Installation 84 | 85 | You can install the development version of `crrri` from GitHub with: 86 | 87 | ``` r 88 | remotes::install_github('rlesur/crrri') 89 | ``` 90 | 91 | ## Using `crrri` interactively 92 | 93 | The `crrri` package is a low-level interface and **is not intended to be 94 | used interactively**: the goal of `crrri` is to provide to R developers 95 | a set of classes and helper functions to build higher levels functions. 96 | 97 | **However, you can discover headless Chrome automation interactively in 98 | your R session using `crrri`**. This will help you to learn the [Chrome 99 | DevTools Protocol](https://chromedevtools.github.io/devtools-protocol), 100 | the `crrri` design and develop higher level functions. 101 | 102 | ### A short-tour 103 | 104 | Assuming that you have configured the `HEADLESS_CHROME` environment 105 | variable (see [above](#system-requirements)), you can start headless 106 | Chrome: 107 | 108 | ``` r 109 | library(crrri) 110 | chrome <- Chrome$new() 111 | ``` 112 | 113 | The `Chrome` class constructor is a **synchronous function**. That means 114 | the R session is on hold until the command terminates. 115 | 116 | The `$connect()` method of the `Chrome` class will connect the R session 117 | to headless Chrome. As the connection process can take some time, the R 118 | session does not hold\[1\]: this is an **asynchronous function**. This 119 | function returns a promise which is fulfilled when R is connected to 120 | Chrome. 121 | 122 | However, you can pass a callback function to the `$connect()` method 123 | using its `callback` argument. In this case, the returned object will be 124 | a connection object: 125 | 126 | ``` r 127 | client <- chrome$connect(callback = function(client) { 128 | client$inspect() 129 | }) 130 | ``` 131 | 132 | The `$inspect()` method of the connection object opens the Chrome 133 | DevTools Inspector in RStudio (\>= 1.2.1335) or in your default web 134 | browser (you can have some trouble if the inspector is not opened in 135 | Chromium/Chrome). It is convenient if you need to inspect the content of 136 | a web page because all that you need is in RStudio. 137 | 138 | ![DevTools Inspector in RStudio 139 | viewer](https://user-images.githubusercontent.com/19177171/56867255-861c3900-69e3-11e9-88cd-2ef29075070f.png) 140 | 141 | In order to discover the [Chrome DevTools 142 | Protocol](https://chromedevtools.github.io/devtools-protocol) commands 143 | and events listeners, it is recommended to extract one of the 144 | domains\[2\] from the connection object: 145 | 146 | ``` r 147 | Page <- client$Page 148 | ``` 149 | 150 | The `Page` object represents the [`Page` 151 | domain](https://chromedevtools.github.io/devtools-protocol/tot/Page). It 152 | possesses methods to send commands or listen to specific events. 153 | 154 | For instance, you can send to Chromium/Chrome the 155 | [`Page.navigate`](https://chromedevtools.github.io/devtools-protocol/tot/Page#method-navigate) 156 | command as follows: 157 | 158 | ``` r 159 | Page$navigate(url = "http://r-project.org") 160 | ``` 161 | 162 | Once the page is loaded by headless Chrome, RStudio looks like this: 163 | 164 | ![R Project website in headless 165 | Chrome](https://user-images.githubusercontent.com/19177171/56867262-8f0d0a80-69e3-11e9-828f-4dddb0bcd492.png) 166 | 167 | You will see in the R console: 168 | 169 | 170 | 171 | This is a promise object that is fulfilled when Chromium/Chrome sends 172 | back to R a message telling that the command was well-received. This 173 | comes from the fact that the `Page$navigate()` function is also 174 | asynchronous. All the asynchronous methods possess a `callback` 175 | argument. When the R session receives the result of the command from 176 | Chrome, R executes this callback function passing the result object to 177 | this function. For instance, you can execute: 178 | 179 | ``` r 180 | Page$navigate(url = "https://ropensci.org/", callback = function(result) { 181 | cat("The R session has received this result from Chrome!\n") 182 | print(result) 183 | }) 184 | ``` 185 | 186 | Once the page is loaded, you will see both the web page and the result 187 | object object in RStudio: 188 | 189 | ![rOpenSci website in headless 190 | Chrome](https://user-images.githubusercontent.com/19177171/56867269-9cc29000-69e3-11e9-8fa4-ca238d3b3566.png) 191 | 192 | To inspect the result of a command you can pass the `print` function to 193 | the `callback` argument: 194 | 195 | ``` r 196 | Page$navigate(url = "https://ropensci.org/", callback = print) 197 | ``` 198 | 199 | #> $frameId 200 | #> [1] "3BB38B10082F28A946332100964486EC" 201 | #> 202 | #> $loaderId 203 | #> [1] "9DCF07625678433563CB03FFF1E8A6AB" 204 | 205 | The result object sent back from Chrome is also the value of the 206 | promises once fulfilled. Recall that if you do not use a callback 207 | function, you get a promise: 208 | 209 | ``` r 210 | async_result <- Page$navigate(url = "http://r-project.org") 211 | ``` 212 | 213 | You can print the value of this promise once fulfilled with: 214 | 215 | ``` r 216 | async_result %...>% print() 217 | ``` 218 | 219 | #> $frameId 220 | #> [1] "3BB38B10082F28A946332100964486EC" 221 | #> 222 | #> $loaderId 223 | #> [1] "7B2383E8F2F39273E18E4D918F1852A0" 224 | 225 | As you can see, this leads to the same result as with a callback 226 | function. 227 | 228 | To sum up, these two forms perform the same actions: 229 | 230 | ``` r 231 | Page$navigate(url = "http://r-project.org", callback = print) 232 | Page$navigate(url = "http://r-project.org") %...>% print() 233 | ``` 234 | 235 | If you interact with headless Chrome in the R console using `crrri`, 236 | these two forms are equivalent. 237 | **However, if you want to use `crrri` to develop higher level functions, 238 | the most reliable way is to use promises.** 239 | 240 | Do not forget to close headless Chrome with: 241 | 242 | ``` r 243 | chrome$close() 244 | ``` 245 | 246 | Since the RStudio viewer has lost the connection, you will see this 247 | screen in RStudio: 248 | 249 | ![headless Chrome 250 | closed](https://user-images.githubusercontent.com/19177171/56867276-a4823480-69e3-11e9-8530-831ac4dd144e.png) 251 | 252 | Now, you can take some time to discover all the commands and events of 253 | the [Chrome DevTools 254 | Protocol](https://chromedevtools.github.io/devtools-protocol/). The 255 | following examples will introduce some of them. 256 | 257 | ### Domains, commands and events listeners 258 | 259 | While working interactively, you can obtain the list of available 260 | domains in your version of Chromium/Chrome. 261 | First, launch Chromium/Chrome and connect the R session to headless 262 | Chromium/Chrome: 263 | 264 | ``` r 265 | chrome <- Chrome$new() 266 | client <- chrome$connect(~ .x$inspect()) 267 | ``` 268 | 269 | Once connected, you just have to print the connection object to get 270 | informations about the connection and availables domains: 271 | 272 | ``` r 273 | client 274 | ``` 275 | 276 | #> 277 | #> connected to: http://localhost:9222/ 278 | #> target type: "page" 279 | #> target ID: "9A576420CADEA9A514C5F027D30B410D" 280 | #> 281 | #> 282 | #> Accessibility (experimental) 283 | #> 284 | #> Animation (experimental) 285 | #> 286 | #> ApplicationCache (experimental) 287 | #> 288 | #> Audits (experimental): Audits domain allows investigation of page violations and possible improvements. 289 | #> 290 | #> Browser: The Browser domain defines methods and events for browser managing. 291 | #> 292 | #> CacheStorage (experimental) 293 | #> 294 | #> Cast (experimental): A domain for interacting with Cast, Presentation API, and Remote Playback API functionalities. 295 | ... 296 | 297 | These informations are directly retrieved from Chromium/Chrome: you may 298 | obtain different informations depending on the Chromium/Chrome version. 299 | 300 | In the most recent versions of the Chrome DevTools Protocol, more than 301 | 40 domains are available. A domain is a set of commands and events 302 | listeners. 303 | 304 | In order to work with a domain, it is recommended to extract it from the 305 | connection object. For instance, if you want to access to the `Runtime` 306 | domain, execute: 307 | 308 | ``` r 309 | Runtime <- client$Runtime 310 | ``` 311 | 312 | If you print this object, this will open the online documentation about 313 | this domain in your browser: 314 | 315 | ``` r 316 | Runtime # opens the online documentation in a browser 317 | ``` 318 | 319 | ## Presentations about crrri 320 | 321 | - **uros2019** - 20/05/2019 322 | ([slides](https://speakerdeck.com/rlesur/headless-chrome-automation-with-r-the-crrri-package)) 323 | - **useR\!2019** - 12/07/2019 324 | ([slides](https://cderv.gitlab.io/user2019-crrri/)) 325 | 326 | ## Examples 327 | 328 | ### Generate a PDF 329 | 330 | Here is an example that produces a PDF of the [R Project 331 | website](https://www.r-project.org/): 332 | 333 | ``` r 334 | library(promises) 335 | library(crrri) 336 | library(jsonlite) 337 | 338 | perform_with_chrome(function(client) { 339 | Page <- client$Page 340 | 341 | Page$enable() %...>% { # await enablement of the Page domain 342 | Page$navigate(url = "https://www.r-project.org/") 343 | Page$loadEventFired() # await the load event 344 | } %...>% { 345 | Page$printToPDF() 346 | } %...>% { # await PDF reception 347 | .$data %>% base64_dec() %>% writeBin("r_project.pdf") 348 | } 349 | }) 350 | ``` 351 | 352 | All the functions of the `crrri` package (commands and event listeners) 353 | return promises (as defined in the **promises** package) by default. 354 | When building higher level functions, do not forget that you have to 355 | deal with promises (those will prevent you to fall into the *Callback 356 | Hell*). 357 | 358 | For instance, you can write a `save_as_pdf` function as follow: 359 | 360 | ``` r 361 | save_url_as_pdf <- function(url) { 362 | function(client) { 363 | Page <- client$Page 364 | 365 | Page$enable() %...>% { 366 | Page$navigate(url = url) 367 | Page$loadEventFired() 368 | } %...>% { 369 | Page$printToPDF() 370 | } %...>% { 371 | .$data %>% 372 | jsonlite::base64_dec() %>% 373 | writeBin(paste0(httr::parse_url(url)$hostname, ".pdf")) 374 | } 375 | } 376 | } 377 | ``` 378 | 379 | You can pass several functions to `perform_with_chrome()`: 380 | 381 | ``` r 382 | save_as_pdf <- function(...) { 383 | list(...) %>% 384 | purrr::map(save_url_as_pdf) %>% 385 | perform_with_chrome(.list = .) 386 | } 387 | ``` 388 | 389 | You have created a `save_as_pdf()` function that can handle multiple 390 | URLs: 391 | 392 | ``` r 393 | save_as_pdf("http://r-project.org", "https://ropensci.org/", "https://rstudio.com") 394 | ``` 395 | 396 | ### Transpose `chrome-remote-interface` JS scripts: dump the DOM 397 | 398 | With `crrri`, you should be able to transpose with minimal efforts some 399 | JS scripts written with the 400 | [`chrome-remote-interface`](https://github.com/cyrus-and/chrome-remote-interface) 401 | node.js module. 402 | 403 | For instance, take [this JS 404 | script](https://github.com/cyrus-and/chrome-remote-interface/wiki/Dump-HTML-after-page-load) 405 | that dumps the DOM: 406 | 407 | ``` js 408 | const CDP = require('chrome-remote-interface'); 409 | 410 | CDP(async(client) => { 411 | const {Network, Page, Runtime} = client; 412 | try { 413 | await Network.enable(); 414 | await Page.enable(); 415 | await Network.setCacheDisabled({cacheDisabled: true}); 416 | await Page.navigate({url: 'https://github.com'}); 417 | await Page.loadEventFired(); 418 | const result = await Runtime.evaluate({ 419 | expression: 'document.documentElement.outerHTML' 420 | }); 421 | const html = result.result.value; 422 | console.log(html); 423 | } catch (err) { 424 | console.error(err); 425 | } finally { 426 | client.close(); 427 | } 428 | }).on('error', (err) => { 429 | console.error(err); 430 | }); 431 | ``` 432 | 433 | Using `crrri`, you can write: 434 | 435 | ``` r 436 | library(promises) 437 | library(crrri) 438 | 439 | async_dump_DOM <- function(client) { 440 | Network <- client$Network 441 | Page <- client$Page 442 | Runtime <- client$Runtime 443 | Network$enable() %...>% { 444 | Page$enable() 445 | } %...>% { 446 | Network$setCacheDisabled(cacheDisabled = TRUE) 447 | } %...>% { 448 | Page$navigate(url = 'https://github.com') 449 | } %...>% { 450 | Page$loadEventFired() 451 | } %...>% { 452 | Runtime$evaluate( 453 | expression = 'document.documentElement.outerHTML' 454 | ) 455 | } %...>% (function(result) { 456 | html <- result$result$value 457 | cat(html, "\n") 458 | }) 459 | } 460 | 461 | perform_with_chrome(async_dump_DOM) 462 | ``` 463 | 464 | If you want to write a higher level function that dump the DOM, you can 465 | embed the main part of this script in a function: 466 | 467 | ``` r 468 | dump_DOM <- function(url, file = "") { 469 | perform_with_chrome(function(client) { 470 | Network <- client$Network 471 | Page <- client$Page 472 | Runtime <- client$Runtime 473 | Network$enable() %...>% { 474 | Page$enable() 475 | } %...>% { 476 | Network$setCacheDisabled(cacheDisabled = TRUE) 477 | } %...>% { 478 | Page$navigate(url = url) 479 | } %...>% { 480 | Page$loadEventFired() 481 | } %...>% { 482 | Runtime$evaluate( 483 | expression = 'document.documentElement.outerHTML' 484 | ) 485 | } %...>% (function(result) { 486 | html <- result$result$value 487 | cat(html, "\n", file = file) 488 | }) 489 | }) 490 | } 491 | ``` 492 | 493 | Now, you can use it for dumping [David 494 | Gohel](https://github.com/davidgohel)’s 495 | [blog](http://www.ardata.fr/post/): 496 | 497 | ``` r 498 | dump_DOM(url = "http://www.ardata.fr/post/") 499 | # or to a file 500 | dump_DOM(url = "http://www.ardata.fr/post/", file = "export-ardata-blog.html") 501 | ``` 502 | 503 | You can find many other examples in the 504 | [wiki](https://github.com/cyrus-and/chrome-remote-interface/wiki) of the 505 | `chrome-remote-interface` module. 506 | 507 | ## Development 508 | 509 | ### Logging Messages 510 | 511 | In `crrri`, there are two types of messages: 512 | 513 | - Those sent during connection/disconnection (mainly for crrri 514 | debugging) 515 | - Those tracking the exchanges between the R websocket client and the 516 | remote websocket server. These lasts are essential for R devs to 517 | develop higher levels packages, either during the development 518 | process and for debugging purposes. 519 | 520 | `crrri` uses [`debugme`](https://github.com/r-lib/debugme) for printing 521 | those messages. It is disable by default and you won’t see any messages 522 | - as a user we think it is fine. However, if you are a developer, you 523 | would expect some information on what is going on. 524 | 525 | You need to add `"crrri"` to the `DEBUGME` environment variable before 526 | loading the package to activate the messaging feature. Currently in 527 | `crrri` there is only one level of message.Also, `debugme` is a 528 | Suggested dependency and you may need to install it manually if not 529 | already installed. 530 | 531 | ## Credits 532 | 533 | Andrea Cardaci for `chrome-remote-interface`. 534 | 535 | Miles McBain for `chradle`. 536 | 537 | Bob Rudis for `decapitated`. 538 | 539 | 1. most of R users should think that this behavior is weird but it is 540 | extremely powerful\! 541 | 542 | 2. a domain is a set of commands, events listeners and types. 543 | --------------------------------------------------------------------------------