Support alternate hosts

NEWS.md

@@ -1,5 +1,25 @@
 # pkgdown (development version)
 
+* pkgdown now detects GitLab urls (since they use the same structure as GitHub)
+  and auto-generates correct links (#1045). 
+
+* You can now control the links to source files (in reference pages and 
+  articles) and issues and users (in the NEWS) with new `repo$url` config
+  option (#1238). This makes it easier to use pkgdown with GitHub enterprise,
+  packages in subdirectories, and other source hosts (like bitbucket).
+
+    ```yaml
+    repo:
+      url:
+        home: https://github.com/r-lib/pkgdown/
+        source: https://github.com/r-lib/pkgdown/blob/master/
+        issue: https://github.com/r-lib/pkgdown/issues/
+        user: https://github.com/
+    ```
+
+    The individual components (e.g. path, issue number, username) are pasted on 
+    the end of these urls so they should have trailing `/`s.
+
 * `deploy_to_branch()` now correctly captures the commit SHA on GitHub Actions
   (@coatless, #1252).
 

R/build-articles.R

@@ -205,7 +205,7 @@ build_article <- function(name,
   default_data <- list(
     pagetitle = front$title,
     opengraph = list(description = front$description %||% pkg$package),
-    source = github_source_links(pkg$github_url, path_rel(input, pkg$src_path)),
+    source = repo_source(pkg, path_rel(input, pkg$src_path)),
     filename = path_file(input)
   )
   data <- utils::modifyList(default_data, data)

R/build-home-citation.R

@@ -51,7 +51,7 @@ data_citations <- function(pkg = ".") {
 build_citation_authors <- function(pkg = ".") {
   pkg <- as_pkgdown(pkg)
 
-  source <- github_source_links(pkg$github_url, "inst/CITATION")
+  source <- repo_source(pkg, "inst/CITATION")
 
   data <- list(
     pagetitle = "Citation and Authors",

R/build-home-index.R

@@ -57,12 +57,12 @@ data_home_sidebar <- function(pkg = ".") {
 data_home_sidebar_links <- function(pkg = ".") {
   pkg <- as_pkgdown(pkg)
 
-  repo <- repo_link(pkg$package)
+  repo <- cran_link(pkg$package)
   meta <- purrr::pluck(pkg, "meta", "home", "links")
 
   links <- c(
     link_url(paste0("Download from ", repo$repo), repo$url),
-    link_url("Browse source code", pkg$github_url),
+    link_url("Browse source code", repo_home(pkg)),
     if (pkg$desc$has_fields("BugReports"))
       link_url("Report a bug", pkg$desc$get("BugReports")[[1]]),
     purrr::map_chr(meta, ~ link_url(.$text, .$href))
@@ -85,7 +85,7 @@ sidebar_section <- function(heading, bullets, class = make_slug(heading)) {
   )
 }
 
-repo_link <- memoise(function(pkg) {
+cran_link <- memoise(function(pkg) {
   if (!has_internet()) {
     return(NULL)
   }

R/build-news.R

@@ -86,7 +86,7 @@ build_news_single <- function(pkg) {
     list(
       contents = purrr::transpose(news),
       pagetitle = "Changelog",
-      source = github_source_links(pkg$github_url, "NEWS.md")
+      source = repo_source(pkg, "NEWS.md")
     ),
     path("news", "index.html")
   )
@@ -154,7 +154,7 @@ data_news <- function(pkg = ".") {
     purrr::walk(tweak_code) %>%
     purrr::walk2(versions, tweak_news_heading, timeline = timeline) %>%
     purrr::map_chr(as.character) %>%
-    purrr::map_chr(add_github_links, pkg = pkg)
+    purrr::map_chr(repo_auto_link, pkg = pkg)
 
   news <- tibble::tibble(
     version = versions,

R/build-reference.R

@@ -235,7 +235,7 @@ data_reference_topic <- function(topic,
   out$pagetitle <- paste0(out$title, " \u2014 ", out$name)
 
   # File source
-  out$source <- github_source_links(pkg$github_url, topic$source)
+  out$source <- repo_source(pkg, topic$source)
   out$filename <- topic$file_in
 
   # Multiple top-level converted to string

R/build.r

@@ -260,6 +260,38 @@
 #' is little documentation, and you'll need to read the existing source
 #' for pkgdown templates to ensure that you use the correct components.
 #'
+#' @section YAML config - repo:
+#' pkgdown automatically generates links to the source repository in a few
+#' places
+#'
+#' * Articles and documentation topics are linked back to the
+#'   underlying source file.
+#'
+#' * The NEWS automatically links issue numbers and user names.
+#'
+#' * The homepage provides a link to  "Browse source code"
+#'
+#' pkgdown automatically figures out the necessary URLs if you link to a GitHub
+#' or GitLab repo in your `BugReports` or `URL` field. Otherwise, you can
+#' supply your own in the `repo` component:
+#'
+#' ```yaml
+#' repo:
+#'   url:
+#'     home: https://github.com/r-lib/pkgdown/
+#'     source: https://github.com/r-lib/pkgdown/blob/master/
+#'     issue: https://github.com/r-lib/pkgdown/issues/
+#'     user: https://github.com/
+#' ```
+#'
+#' * `home`: path to package home on source code repository.
+#' * `source:`: path to source of individual file in master branch.
+#' * `issue`: path to individual issue.
+#' * `user`: path to user.
+#'
+#' The varying components (e.g. path, issue number, user name) are pasted on
+#' the end of these URLs so they should have trailing `/`s.
+#'
 #' @section Options:
 #' Users with limited internet connectivity can disable CRAN checks by setting
 #' `options(pkgdown.internet = FALSE)`. This will also disable some features

R/navbar.R

@@ -78,8 +78,8 @@ navbar_components <- function(pkg = ".") {
   menu$articles <-  menu("Articles", menu_links(vignettes$title, vignettes$file_out))
   menu$news <- navbar_news(pkg)
 
-  if (!is.null(pkg$github_url)) {
-    menu$github <- menu_icon("github", pkg$github_url, style = "fab")
+  if (!is.null(pkg$repo$url$home)) {
+    menu$github <- menu_icon("github", repo_home(pkg), style = "fab")
   }
 
   print_yaml(menu)

R/package.r

@@ -42,11 +42,11 @@ as_pkgdown <- function(pkg = ".", override = list()) {
 
       src_path = path_abs(pkg),
       dst_path = path_abs(dst_path),
-      github_url = pkg_github_url(desc),
 
       desc = desc,
       meta = meta,
       figures = meta_figures(meta),
+      repo = package_repo(desc, meta),
 
       development = development,
       topics = package_topics(pkg, package),

R/repo.R

@@ -0,0 +1,92 @@
+repo_home <- function(pkg, paths) {
+  pkg$repo$url$home
+}
+
+repo_source <- function(pkg, paths) {
+  url <- pkg$repo$url
+  if (is.null(url$source) || length(paths) == 0) {
+    return()
+  }
+
+  links <- a(
+    paste0("<code>", escape_html(paths), "</code>"),
+    paste0(url$source, paths)
+  )
+
+  n <- length(links)
+  if (n >= 4) {
+    links <- c(links[1:3], paste0("and ", n - 3, " more"))
+  }
+
+  paste0("Source: ", paste(links, collapse = ", "))
+}
+
+repo_auto_link <- function(pkg, text) {
+  url <- pkg$repo$url
+
+  if (!is.null(url$user)) {
+    user_link <- paste0("\\1<a href='", url$user, "\\2'>@\\2</a>")
+    text <- gsub("(\\s|^|\\()@([-\\w]+)", user_link, text, perl = TRUE)
+  }
+
+  if (!is.null(url$issue)) {
+    issue_link <- paste0("<a href='", url$issue, "\\1'>#\\1</a>")
+    text <- gsub("#(\\d+)", issue_link, text, perl = TRUE)
+  }
+
+  text
+}
+
+# Package data -------------------------------------------------------------
+
+package_repo <- function(desc, meta) {
+  # Use metadata if available
+  if (has_name(meta, "repo")) {
+    return(meta[["repo"]])
+  }
+
+  # Otherwise try and guess from BugReports + URLs
+  urls <- c(
+    desc$get_field("BugReports", default = character()),
+    desc$get_urls()
+  )
+
+  gh_links <- grep("^https?://git(hub|lab).com/", urls, value = TRUE)
+  if (length(gh_links) > 0) {
+    return(repo_meta_gh_like(gh_links[[1]]))
+  }
+
+  NULL
+}
+
+repo_meta <- function(home = NULL, source = NULL, issue = NULL, user = NULL) {
+  list(
+    url = list(
+      home = home,
+      source = source,
+      issue = issue,
+      user = user
+    )
+  )
+}
+
+repo_meta_gh_like <- function(link) {
+  gh <- parse_github_like_url(link)
+  repo_meta(
+    paste0(gh$host, "/", gh$owner, "/", gh$repo, "/"),
+    paste0(gh$host, "/", gh$owner, "/", gh$repo, "/blob/master/"),
+    paste0(gh$host, "/", gh$owner, "/", gh$repo, "/issues/"),
+    paste0(gh$host, "/")
+  )
+}
+
+# adapted from usethis:::github_link()
+parse_github_like_url <- function(link) {
+  rx <- paste0(
+    "^",
+    "(?<host>https?://[^/]+)/",
+    "(?<owner>[^/]+)/",
+    "(?<repo>[^/#]+)"
+  )
+  rematch2::re_match(link, rx)
+}

tests/testthat/test-build-home-index.R

@@ -6,18 +6,18 @@ context("test-build-home-index")
 test_that("package repo verification", {
   skip_on_cran() # requires internet connection
 
-  expect_null(repo_link("notarealpkg"))
+  expect_null(cran_link("notarealpkg"))
 
   expect_equal(
-    repo_link("dplyr"),
+    cran_link("dplyr"),
     list(
       repo = "CRAN",
       url = "https://cloud.r-project.org/package=dplyr"
     )
   )
 
   expect_equal(
-    repo_link("Biobase"),
+    cran_link("Biobase"),
     list(
       repo = "BIOC",
       url = "https://www.bioconductor.org/packages/Biobase"