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
+ )
+})