Fix HTTP(S) git repo installation

NEWS.md

@@ -2,6 +2,8 @@
 
 * Re-license as MIT. (#551)
 
+* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file, and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s)://<host>/<username>/<repo>[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603).
+
 # remotes 2.3.0
 
 ## Major changes
@@ -75,8 +77,8 @@
   field. In such a case, the values for `getOption("repos")` and
   `getOption("pkgType")` will be used (respectively).
 
-* `install_gitlab()` now installs from repositories in subgroups and with dots 
-  in their name. `subdir` is now an explicit argument instead of implicit in 
+* `install_gitlab()` now installs from repositories in subgroups and with dots
+  in their name. `subdir` is now an explicit argument instead of implicit in
   `repo` (@robertdj, #259, #420).
 
 * `install()` now passes the ellipsis `...` to `install_deps()` (@Neil-Schneider, #411)

R/install-git.R

@@ -26,9 +26,9 @@
 #' @export
 #' @examples
 #' \dontrun{
-#' install_git("git://github.com/hadley/stringr.git")
-#' install_git("git://github.com/hadley/stringr.git", ref = "stringr-0.2")
-#'}
+#' install_git("https://github.com/hadley/stringr.git")
+#' install_git("https://github.com/hadley/stringr.git", ref = "stringr-0.2")
+#' }
 install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL,
                         credentials = git_credentials(),
                         git = c("auto", "git2r", "external"),
@@ -41,33 +41,35 @@ install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL,
                         repos = getOption("repos"),
                         type = getOption("pkgType"),
                         ...) {
-
   if (!missing(branch)) {
     warning("`branch` is deprecated, please use `ref`")
     ref <- branch
   }
 
-  remotes <- lapply(url, git_remote, subdir = subdir, ref = ref,
-    credentials = credentials, git = match.arg(git))
-
-  install_remotes(remotes, credentials = credentials,
-                  dependencies = dependencies,
-                  upgrade = upgrade,
-                  force = force,
-                  quiet = quiet,
-                  build = build,
-                  build_opts = build_opts,
-                  build_manual = build_manual,
-                  build_vignettes = build_vignettes,
-                  repos = repos,
-                  type = type,
-                  ...)
+  remotes <- lapply(url, git_remote,
+    subdir = subdir, ref = ref,
+    credentials = credentials, git = match.arg(git)
+  )
+
+  install_remotes(remotes,
+    credentials = credentials,
+    dependencies = dependencies,
+    upgrade = upgrade,
+    force = force,
+    quiet = quiet,
+    build = build,
+    build_opts = build_opts,
+    build_manual = build_manual,
+    build_vignettes = build_vignettes,
+    repos = repos,
+    type = type,
+    ...
+  )
 }
 
 
 git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials(),
                        git = c("auto", "git2r", "external"), ...) {
-
   git <- match.arg(git)
   if (git == "auto") {
     git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external"
@@ -77,7 +79,10 @@ git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credent
     stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE)
   }
 
-  list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials)
+  meta <- re_match(url, "(?:(?<url>[^@]*))(?:@(?<ref>.*))?")
+  ref <- ref %||% (if (meta$ref == "") NULL else meta$ref)
+
+  list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](meta$url, subdir, ref, credentials)
 }
 
 
@@ -136,49 +141,65 @@ remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha =
 
 #' @export
 remote_package_name.git2r_remote <- function(remote, ...) {
-
   tmp <- tempfile()
   on.exit(unlink(tmp))
   description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION"))
 
-  # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol
-  # or server doesn't support that return NA
-  res <- try(silent = TRUE,
-    system_check(git_path(),
-      args = c("archive", "-o", tmp, "--remote", remote$url,
-        if (is.null(remote$ref)) "HEAD" else remote$ref,
-        description_path),
-      quiet = TRUE))
-
-  if (inherits(res, "try-error")) {
-    return(NA_character_)
-  }
+  if (grepl("^https?://", remote$url)) {
+    url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path)
+    download(tmp, url)
+    read_dcf(tmp)$Package
+  } else {
+    # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol
+    # or server doesn't support that return NA
+    res <- try(
+      silent = TRUE,
+      system_check(git_path(),
+        args = c(
+          "archive", "-o", tmp, "--remote", remote$url,
+          if (is.null(remote$ref)) "HEAD" else remote$ref,
+          description_path
+        ),
+        quiet = TRUE
+      )
+    )
+
+    if (inherits(res, "try-error")) {
+      return(NA_character_)
+    }
 
-  # git archive returns a tar file, so extract it to tempdir and read the DCF
-  utils::untar(tmp, files = description_path, exdir = tempdir())
+    # git archive returns a tar file, so extract it to tempdir and read the DCF
+    utils::untar(tmp, files = description_path, exdir = tempdir())
 
-  read_dcf(file.path(tempdir(), description_path))$Package
+    read_dcf(file.path(tempdir(), description_path))$Package
+  }
 }
 
 #' @export
 remote_sha.git2r_remote <- function(remote, ...) {
-  tryCatch({
-    # set suppressWarnings in git2r 0.23.0+
-    res <- suppressWarnings(git2r::remote_ls(remote$url, credentials=remote$credentials))
+  tryCatch(
+    {
+      # set suppressWarnings in git2r 0.23.0+
+      res <- suppressWarnings(git2r::remote_ls(remote$url, credentials = remote$credentials))
 
-    ref <- remote$ref %||% "HEAD"
+      ref <- remote$ref %||% "HEAD"
 
-    if(ref != "HEAD") ref <- paste0("/",ref)
+      if (ref != "HEAD") ref <- paste0("/", ref)
 
-    found <- grep(pattern = paste0(ref,"$"), x = names(res))
+      found <- grep(pattern = paste0(ref, "$"), x = names(res))
 
-    # If none found, it is either a SHA, so return the pinned sha or NA
-    if (length(found) == 0) {
-      return(remote$ref %||% NA_character_)
-    }
+      # If none found, it is either a SHA, so return the pinned sha or NA
+      if (length(found) == 0) {
+        return(remote$ref %||% NA_character_)
+      }
 
-    unname(res[found[1]])
-  }, error = function(e) { warning(e);  NA_character_})
+      unname(res[found[1]])
+    },
+    error = function(e) {
+      warning(e)
+      NA_character_
+    }
+  )
 }
 
 #' @export
@@ -199,7 +220,7 @@ remote_download.xgit_remote <- function(x, quiet = FALSE) {
 
   bundle <- tempfile()
 
-  args <- c('clone', '--depth', '1', '--no-hardlinks')
+  args <- c("clone", "--depth", "1", "--no-hardlinks")
   args <- c(args, x$args, x$url, bundle)
   git(paste0(args, collapse = " "), quiet = quiet)
 
@@ -244,8 +265,10 @@ remote_sha.xgit_remote <- function(remote, ...) {
     return(remote$ref %||% NA_character_)
   }
 
-  refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
-    header = FALSE)
+  refs_df <- read.delim(
+    text = refs, stringsAsFactors = FALSE, sep = "\t",
+    header = FALSE
+  )
   names(refs_df) <- c("sha", "ref")
 
   refs_df$sha[[1]]