diff --git a/.Rbuildignore b/.Rbuildignore index 7c6f513..d7b6693 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ $run_dev.* ^\.rscignore$ ^CLAUDE\.md$ ^manifest\.json$ +^ROADMAP\.md$ diff --git a/R/app_server.R b/R/app_server.R index afabaf1..6ad9f69 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -28,12 +28,45 @@ app_server <- function(input, output, session) { ) ) } + } else if (length(rv$site$dropped_css_links) > 0) { + # Stylesheets exist, but every one of them is served from another + # domain (typically a dedicated asset CDN). + dropped <- rv$site$dropped_css_links + shown <- dropped[seq_len(min(5, length(dropped)))] + + showModal( + modalDialog( + title = "External stylesheets only", + HTML( + paste0( + "This website loads ", length(dropped), + " stylesheet(s), but all of them are served from another domain, ", + "so ShinyCopy cannot tell brand CSS from third-party CSS.

", + "Discarded links:" + ) + ), + tags$ul( + lapply( + shown, + function(link) tags$li(tags$code(class = "text-break", link)) + ) + ), + size = "m", + easyClose = TRUE + ) + ) } else { showModal( modalDialog( - title = "Error", - HTML("No CSS links found on the website.
ShinyCopy doesn\'t support inline CSS yet."), - HTML("ShinyCopy is looking for CSS links starting with domain name (e.g. https://thinkr.fr/...).
"), + title = "No stylesheet found", + HTML( + paste0( + "No <link rel=\"stylesheet\"> tag was found on ", + "", rv$site$domain, ".

", + "This usually means the site ships its CSS inline in the HTML, ", + "or renders the page with JavaScript. ShinyCopy supports neither yet." + ) + ), size = "m", easyClose = TRUE ) diff --git a/R/css2r.R b/R/css2r.R index aa6762b..6c00fe0 100644 --- a/R/css2r.R +++ b/R/css2r.R @@ -17,18 +17,20 @@ #' #' @importFrom R6 R6Class #' @importFrom rvest read_html html_nodes html_attr url_absolute -#' @importFrom urltools domain param_get +#' @importFrom urltools domain param_get suffix_extract #' @importFrom curl has_internet -#' @importFrom httr GET content +#' @importFrom httr GET content status_code #' @importFrom cli cli_alert cli_alert_danger cli_alert_info cli_alert_warning cli_alert_success -#' @importFrom purrr map map_chr keep compact +#' @importFrom purrr map map_chr map_lgl keep compact #' @importFrom bslib bs_theme font_google #' #' @field url URL of the website to analyze -#' @field domain Website domain +#' @field resolved_url URL actually reached after following redirects +#' @field domain Registrable domain (eTLD+1) of the website #' @field html_page HTML content of the page #' @field all_css_links List of all found CSS links #' @field domain_css_links Filtered CSS links from the domain +#' @field dropped_css_links CSS links discarded because they belong to another domain #' @field css_content Downloaded CSS content #' @field all_colors List of all found colors #' @field top_colors Analyzed main colors @@ -50,10 +52,12 @@ css2r <- R6Class( classname = "css2r", public = list( url = NULL, + resolved_url = NULL, domain = NULL, html_page = NULL, all_css_links = NULL, domain_css_links = NULL, + dropped_css_links = NULL, css_content = NULL, all_colors = NULL, top_colors = NULL, @@ -68,7 +72,7 @@ css2r <- R6Class( #' @return A new `css2r` object initialize = function(url, on_initialize = TRUE) { self$url <- url - self$domain <- domain(url) + self$domain <- private$registrable_domain(url) if (isTRUE(on_initialize)) { if (self$check_internet()) { @@ -108,7 +112,28 @@ css2r <- R6Class( #' @return Invisible. Updates the html_page field of the object download_html = function() { tryCatch({ - self$html_page <- read_html(x = self$url) + response <- GET(self$url) + + if (httr::status_code(response) >= 400) { + private$danger("Failed to download html page (HTTP ", httr::status_code(response), ")") + return(invisible(FALSE)) + } + + # The requested URL often redirects (typically apex -> www). Everything + # downstream — relative link resolution and the domain filter — must be + # resolved against the URL we actually landed on, not the one typed in. + self$resolved_url <- response$url + self$domain <- private$registrable_domain(self$resolved_url) + + self$html_page <- read_html( + content(response, as = "text", encoding = "UTF-8") + ) + + # Only worth reporting when the host actually changed, not when curl + # merely normalised a trailing slash. + if (!identical(domain(self$resolved_url), domain(self$url))) { + private$info("Redirected to ", self$resolved_url) + } private$success("html page downloaded") }, error = function(e) { private$danger("Failed to download html page") @@ -142,17 +167,34 @@ css2r <- R6Class( return(invisible(FALSE)) } - self$domain_css_links <- self$all_css_links |> + base_url <- if (is.null(self$resolved_url)) self$url else self$resolved_url + site_domain <- private$registrable_domain(base_url) + + absolute_links <- self$all_css_links |> map_chr( .f = ~ ifelse( test = startsWith(.x, "http"), yes = .x, - no = url_absolute(.x, self$url) + no = url_absolute(.x, base_url) ) - ) |> - keep( - .p = ~ domain(.x) == self$domain ) + + # Compare registrable domains (eTLD+1), not full hosts: www.example.com and + # example.com are the same site, while cdn.other.com is not. + is_same_site <- purrr::map_lgl( + .x = absolute_links, + .f = ~ identical(private$registrable_domain(.x), site_domain) + ) + + self$domain_css_links <- unname(absolute_links[is_same_site]) + self$dropped_css_links <- unname(absolute_links[!is_same_site]) + + if (length(self$dropped_css_links) > 0) { + private$info( + length(self$dropped_css_links), + " CSS link(s) discarded (served from another domain)" + ) + } private$success("CSS links filtered") }, @@ -367,6 +409,24 @@ css2r <- R6Class( cli::cli_alert_success(cli::col_black(...)) }, + # urltools::domain() returns the full host, subdomain included, so + # "www.example.com" != "example.com". Reduce to the registrable domain + # (eTLD+1) so that a redirect to www does not discard the whole site. + registrable_domain = function(url) { + host <- domain(url) + if (length(host) == 0 || is.na(host) || !nzchar(host)) { + return(NA_character_) + } + + parts <- urltools::suffix_extract(host) + if (nrow(parts) == 0 || is.na(parts$domain[1]) || is.na(parts$suffix[1])) { + # IP address, localhost, or a suffix absent from the public suffix list + return(host) + } + + paste0(parts$domain[1], ".", parts$suffix[1]) + }, + get_css_content = function(link) { tryCatch({ res <- GET(link) |> diff --git a/tests/testthat/test-css2r.R b/tests/testthat/test-css2r.R index 2abb866..8267d0c 100644 --- a/tests/testthat/test-css2r.R +++ b/tests/testthat/test-css2r.R @@ -36,3 +36,40 @@ test_that("css2r works", { expect_true(nchar(thinkr$shiny_code) > 0) expect_true(grepl("bslib::bs_theme", thinkr$shiny_code)) }) + +test_that("a redirect to www does not discard the whole site", { + + skip_if_offline() + + # lemonde.fr redirects to www.lemonde.fr, and serves its CSS from the www host. + # Comparing full hosts used to drop every stylesheet and report "no CSS found". + apex <- css2r$new(url = "https://lemonde.fr/") + + expect_equal(apex$domain, "lemonde.fr") + # The landing path is geo-dependent (the site redirects to /en/ outside + # France), so assert on the host we were sent to, not on the full URL. + expect_equal(urltools::domain(apex$resolved_url), "www.lemonde.fr") + expect_true(length(apex$domain_css_links) > 0) + expect_length(apex$dropped_css_links, 0) + + # Typing the canonical host must give the same result + www <- css2r$new(url = "https://www.lemonde.fr/") + + expect_equal(www$domain, apex$domain) + expect_equal(www$domain_css_links, apex$domain_css_links) +}) + +test_that("stylesheets from another domain are dropped and reported", { + + skip_if_offline() + + thinkr <- css2r$new(url = "https://thinkr.fr") + + # thinkr.fr loads a highlight.js theme from cdnjs, which is not brand CSS + expect_true(length(thinkr$dropped_css_links) > 0) + expect_true(all(grepl("^https?://", thinkr$dropped_css_links))) + expect_length( + intersect(thinkr$domain_css_links, thinkr$dropped_css_links), + 0 + ) +})