feat: allow www domain

.Rbuildignore

@@ -16,3 +16,4 @@ $run_dev.*
 ^\.rscignore$
 ^CLAUDE\.md$
 ^manifest\.json$
+^ROADMAP\.md$

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 <b>", length(dropped),
+                    " stylesheet(s)</b>, but all of them are served from another domain, ",
+                    "so ShinyCopy cannot tell brand CSS from third-party CSS.<br><br>",
+                    "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. <br> ShinyCopy doesn\'t support inline CSS yet."),
-                HTML("ShinyCopy is looking for CSS links starting with domain name (e.g. https://thinkr.fr/...).<br>"),
+                title = "No stylesheet found",
+                HTML(
+                  paste0(
+                    "No <code>&lt;link rel=\"stylesheet\"&gt;</code> tag was found on ",
+                    "<b>", rv$site$domain, "</b>.<br><br>",
+                    "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
               )

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

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