r-lib · jimhester · Aug 28, 2018 · Aug 27, 2018 · Aug 28, 2018
diff --git a/NEWS.md b/NEWS.md
@@ -5,6 +5,11 @@
 
 # Development
 
+* `install_()` functions now download tarballs (.tar.gz) files rather than zip
+  archives (.zip). This results in generally smaller files and avoids issues
+  with script permissions being lost and strange behavior of some external
+  unzip programs on Windows (#96).
+
 * Do not include the BioCextra repository in versions after it was deprecated
   (R 3.5+, Bioc 3.6+).
 

diff --git a/R/git.R b/R/git.R
@@ -1,23 +1,26 @@
 
 # Extract the commit hash from a git archive. Git archives include the SHA1
-# hash as the comment field of the zip central directory record
+# hash as the comment field of the tarball pax extended header
 # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
-# Since we know it's 40 characters long we seek that many bytes minus 2
-# (to confirm the comment is exactly 40 bytes long)
-git_extract_sha1 <- function(bundle) {
+# For GitHub archives this should be the first header after the default one
+# (512 byte) header.
+git_extract_sha1_tar <- function(bundle) {
 
   # open the bundle for reading
-  conn <- file(bundle, open = "rb", raw = TRUE)
+  # We use gzcon for everything because (from ?gzcon)
+  # > Reading from a connection which does not supply a ‘gzip’ magic
+  # > header is equivalent to reading from the original connection
+  conn <- gzcon(file(bundle, open = "rb", raw = TRUE))
   on.exit(close(conn))
 
-  # seek to where the comment length field should be recorded
-  seek(conn, where = -0x2a, origin = "end")
+  # The default pax header is 512 bytes long and the first pax extended header
+  # with the comment should be 51 bytes long
+  # `52 comment=` (11 chars) + 40 byte SHA1 hash
+  len <- 0x200 + 0x33
+  res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len])
 
-  # verify the comment is length 0x28
-  len <- readBin(conn, "raw", n = 2)
-  if (len[1] == 0x28 && len[2] == 0x00) {
-    # read and return the SHA1
-    rawToChar(readBin(conn, "raw", n = 0x28))
+  if (grepl("^52 comment=", res)) {
+    sub("52 comment=", "", res)
   } else {
     NULL
   }

diff --git a/R/install-bioc.R b/R/install-bioc.R
@@ -149,13 +149,13 @@ remote_download.bioc_xgit_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
   url <- paste0(x$mirror, "/", x$repo)
 
   if (!is.null(bundle)) {
     r <- git2r::repository(bundle)
     sha <- git_repo_sha1(r)
-  } else {
+  } else if (is_na(sha)) {
     sha <- NULL
   }
 
@@ -170,13 +170,17 @@ remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL) {
 }
 
 #' @export
-remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
+  if (is_na(sha)) {
+    sha <- NULL
+  }
+
   list(
     RemoteType = "bioc_xgit",
     RemoteMirror = x$mirror,
     RemoteRepo = x$repo,
     RemoteRelease = x$release,
-    RemoteSha = remote_sha(x),
+    RemoteSha = sha,
     RemoteBranch = x$branch,
     RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
   )

diff --git a/R/install-bitbucket.R b/R/install-bitbucket.R
@@ -65,24 +65,20 @@ remote_download.bitbucket_remote <- function(x, quiet = FALSE) {
     message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref)
   }
 
-  dest <- tempfile(fileext = paste0(".zip"))
+  dest <- tempfile(fileext = paste0(".tar.gz"))
 
   url <- bitbucket_download_url(x$username, x$repo, x$ref, host = x$host, auth = basic_auth(x))
 
   download(dest, url, basic_auth = basic_auth(x))
 }
 
 #' @export
-remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL) {
-  # Determine sha as efficiently as possible
-  if (!is.null(x$sha)) {
-    # Might be cached already (because re-installing)
-    sha <- x$sha
-  } else if (!is.null(bundle)) {
-    # Might be able to get from zip archive
-    sha <- git_extract_sha1(bundle)
-  } else {
-    sha <- remote_sha(x)
+remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
+  if (!is.null(bundle)) {
+        # Might be able to get from archive
+    sha <- git_extract_sha1_tar(bundle)
+  } else if (is.na(sha)) {
+    sha <- NULL
   }
 
   list(
@@ -156,7 +152,7 @@ bitbucket_download_url <- function(username, repo, ref = "master",
   tmp <- tempfile()
   download(tmp, url, basic_auth = auth)
 
-  paste0(build_url(fromJSONFile(tmp)$links$html$href, "get", ref), ".zip")
+  paste0(build_url(fromJSONFile(tmp)$links$html$href, "get", ref), ".tar.gz")
 }
 
 bitbucket_password <- function(quiet = TRUE) {

diff --git a/R/install-git.R b/R/install-git.R
@@ -73,12 +73,12 @@ remote_download.git2r_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
   if (!is.null(bundle)) {
     r <- git2r::repository(bundle)
     sha <- git2r::commits(r)[[1]]$sha
   } else {
-    sha <- NA_character_
+    sha <- NULL
   }
 
   list(
@@ -163,13 +163,17 @@ remote_download.xgit_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
+  if (is_na(sha)) {
+    sha <- NULL
+  }
+
   list(
     RemoteType = "xgit",
     RemoteUrl = x$url,
     RemoteSubdir = x$subdir,
     RemoteBranch = x$branch,
-    RemoteSha = remote_sha(x),
+    RemoteSha = sha,
     RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
   )
 }

diff --git a/R/install-github.R b/R/install-github.R
@@ -75,25 +75,21 @@ remote_download.github_remote <- function(x, quiet = FALSE) {
     message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref)
   }
 
-  dest <- tempfile(fileext = paste0(".zip"))
+  dest <- tempfile(fileext = paste0(".tar.gz"))
   src_root <- build_url(x$host, "repos", x$username, x$repo)
-  src <- paste0(src_root, "/zipball/", utils::URLencode(x$ref, reserved = TRUE))
+  src <- paste0(src_root, "/tarball/", utils::URLencode(x$ref, reserved = TRUE))
 
   download(dest, src, auth_token = x$auth_token)
 }
 
 #' @export
-remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL) {
-  # Determine sha as efficiently as possible
-  if (!is.null(x$sha)) {
-    # Might be cached already (because re-installing)
-    sha <- x$sha
-  } else if (!is.null(bundle)) {
-    # Might be able to get from zip archive
-    sha <- git_extract_sha1(bundle)
-  } else {
-    # Otherwise can use github api
-    sha <- github_commit(x$username, x$repo, x$ref)
+remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
+
+  if (!is.null(bundle)) {
+    # Might be able to get from archive
+    sha <- git_extract_sha1_tar(bundle)
+  } else if (is_na(sha)) {
+    sha <- NULL
   }
 
   list(

diff --git a/R/install-gitlab.R b/R/install-gitlab.R
@@ -46,10 +46,10 @@ gitlab_remote <- function(repo,
 
 #' @export
 remote_download.gitlab_remote <- function(x, quiet = FALSE) {
-  dest <- tempfile(fileext = paste0(".zip"))
+  dest <- tempfile(fileext = paste0(".tar.gz"))
 
   src_root <- build_url(x$host, x$username, x$repo)
-  src <- paste0(src_root, "/repository/archive.zip?ref=", utils::URLencode(x$ref, reserved = TRUE))
+  src <- paste0(src_root, "/repository/archive.tar.gz?ref=", utils::URLencode(x$ref, reserved = TRUE))
 
   if (!quiet) {
     message("Downloading GitLab repo ", x$username, "/", x$repo, "@", x$ref,
@@ -60,14 +60,13 @@ remote_download.gitlab_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL) {
-  # Determine sha as efficiently as possible
+remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
+
   if (!is.null(bundle)) {
-    # Might be able to get from zip archive
-    sha <- git_extract_sha1(bundle)
-  } else {
-    # Otherwise can lookup with remote_ls
-    sha <- remote_sha(x)
+    # Might be able to get from archive
+    sha <- git_extract_sha1_tar(bundle)
+  } else if (is_na(sha)) {
+    sha <- NULL
   }
 
   list(

diff --git a/R/install-local.R b/R/install-local.R
@@ -40,7 +40,7 @@ remote_download.local_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
   list(
     RemoteType = "local",
     RemoteUrl = x$path,

diff --git a/R/install-remote.R b/R/install-remote.R
@@ -42,7 +42,7 @@ install_remote <- function(remote, ..., force = FALSE, quiet = FALSE) {
 
   update_submodules(source, quiet)
 
-  add_metadata(source, remote_metadata(remote, bundle, source))
+  add_metadata(source, remote_metadata(remote, bundle, source, remote_sha))
 
   # Because we've modified DESCRIPTION, its original MD5 value is wrong
   clear_description_md5(source)
@@ -82,7 +82,7 @@ remote <- function(type, ...) {
 is.remote <- function(x) inherits(x, "remote")
 
 remote_download <- function(x, quiet = FALSE) UseMethod("remote_download")
-remote_metadata <- function(x, bundle = NULL, source = NULL) UseMethod("remote_metadata")
+remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata")
 remote_package_name <- function(remote, ...) UseMethod("remote_package_name")
 remote_sha <- function(remote, ...) UseMethod("remote_sha")
 

diff --git a/R/install-svn.R b/R/install-svn.R
@@ -76,14 +76,14 @@ remote_download.svn_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
 
   if (!is.null(bundle)) {
     in_dir(bundle, {
       revision <- svn_revision()
     })
   } else {
-    revision <- NA_character_
+    revision <- sha
   }
 
   list(

diff --git a/R/install-url.R b/R/install-url.R
@@ -41,7 +41,7 @@ remote_download.url_remote <- function(x, quiet = FALSE) {
 }
 
 #' @export
-remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL) {
+remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
   list(
     RemoteType = "url",
     RemoteUrl = x$url,

diff --git a/R/utils.R b/R/utils.R
@@ -289,3 +289,7 @@ download_url <- function(url) {
   }
   url
 }
+
+is_na <- function(x) {
+  length(x) == 1 && is.na(x)
+}
diff --git a/tests/testthat/test-git.R b/tests/testthat/test-git.R
@@ -1,15 +1,15 @@
 
 context("Git")
 
-test_that("git_extract_sha1", {
+test_that("git_extract_sha1_tar", {
 
   skip_on_cran()
   skip_if_offline()
   skip_if_over_rate_limit()
 
   sha <- "fbae60ced0afee0e7c0f8dc3b5b1bb48d303f3dd"
   url <- paste0(
-    "https://api.github.com/repos/hadley/devtools/zipball/",
+    "https://api.github.com/repos/hadley/devtools/tarball/",
     sha
   )
 
@@ -18,7 +18,7 @@ test_that("git_extract_sha1", {
   download(tmp, url, auth_token = github_pat())
 
   expect_equal(
-    git_extract_sha1(tmp),
+    git_extract_sha1_tar(tmp),
     sha
   )
 })

diff --git a/tests/testthat/test-install-bitbucket.R b/tests/testthat/test-install-bitbucket.R
@@ -57,7 +57,7 @@ test_that("remote_download.bitbucket_remote", {
 test_that("remote_metadata.bitbucket_remote", {
 
   expect_equal(
-    remote_metadata.bitbucket_remote(list(sha = "foobar"))$RemoteSha,
+    remote_metadata.bitbucket_remote(list(), sha = "foobar")$RemoteSha,
     "foobar"
   )
 })

diff --git a/tests/testthat/test-install-git.R b/tests/testthat/test-install-git.R
@@ -112,7 +112,7 @@ test_that("remote_metadata.xgit_remote", {
     RemoteUrl = "foo",
     RemoteSubdir = "foo2",
     RemoteBranch = "foo3",
-    RemoteSha = NA_character_,
+    RemoteSha = NULL,
     RemoteArgs = NULL
   )
 
@@ -130,7 +130,7 @@ test_that("remote_metadata.git2r_remote", {
     RemoteUrl = "foo",
     RemoteSubdir = "foo2",
     RemoteBranch = "foo3",
-    RemoteSha = NA_character_
+    RemoteSha = NULL
   )
 
   expect_equal(r, e)

diff --git a/tests/testthat/test-install-github.R b/tests/testthat/test-install-github.R
@@ -150,25 +150,29 @@ test_that("remote_download.github_remote messages", {
 test_that("remote_metadata.github_remote", {
 
   expect_equal(
-    remote_metadata.github_remote(list(sha = "foobar"))$RemoteSha,
+    remote_metadata.github_remote(list(), sha = "foobar")$RemoteSha,
     "foobar"
   )
+})
+
+
+test_that("remote_sha.github_remote", {
 
   skip_on_cran()
   skip_if_offline()
   skip_if_over_rate_limit()
 
   expect_equal(
-    remote_metadata.github_remote(
+    remote_sha.github_remote(
       list(
         username = "cran",
         repo = "falsy",
-        ref = "1.0"
+        ref = "1.0",
+        host = "api.github.com"
       )
-    )$RemoteSha,
+    ),
     "0f39d9eb735bf16909831c0bb129063dda388375"
   )
-
 })
 
 test_that("github_pull", {
-Original file line number
+Diff line change
@@ Expand Up / @@ -289,3 +289,7 @@ download_url <- function(url) { @@
       }
       url
     }
+    is_na <- function(x) {
+      length(x) == 1 && is.na(x)
+    }