Merge pull request #481 from mariamedp/feature/bitbucket

Added support for Bitbucket

R/available-updates.R

@@ -75,11 +75,79 @@ githubUpdates <- function(lib.loc = .libPaths()) {
   }))
 }
 
+
+bitbucketUpdates <- function(lib.loc = .libPaths()) {
+
+  do.call(rbind, enumerate(lib.loc, function(lib) {
+    pkgs <- list.files(lib, full.names = TRUE)
+    DESCRIPTIONS <- enumerate(pkgs, function(pkg) {
+      path <- file.path(pkg, "DESCRIPTION")
+      if (!file.exists(path)) return(NULL)
+      readDcf(path)
+    })
+    names(DESCRIPTIONS) <- pkgs
+    DESCRIPTIONS <-
+      Filter(function(x) "RemoteType" %in% colnames(x) && x[,"RemoteType"] == "bitbucket", DESCRIPTIONS)
+    if (!length(DESCRIPTIONS)) return(NULL)
+    if (!requireNamespace("httr")) stop("Need package 'httr' to check for Bitbucket updates")
+    do.call(rbind, enumerate(DESCRIPTIONS, function(x) {
+      url <- file.path("https://api.bitbucket.org",
+                       "2.0",
+                       "repositories",
+                       x[, "RemoteUsername"],
+                       x[, "RemoteRepo"],
+                       "refs",
+                       "branches")
+      response <- httr::GET(url)
+      status <- response$status
+      if (response$status == 403) {
+        warning("rejected by server", call. = FALSE)
+        sha <- NA
+      } else if (!response$status == 200) {
+        warning("failed to get tracking information for Bitbucket package '",
+                x[, "Package"],
+                "'; did its associated repository move?",
+                call. = FALSE)
+        sha <- NA
+      } else {
+        content <- httr::content(response, "parsed")
+        ## Find the index of the response with the appropriate name
+        index <- which(sapply(content$values, `[[`, "name") == x[, "RemoteRef"])
+        if (!length(index)) {
+          warning("no reference '", x[, "RemoteRef"],
+                  "' found associated with this repository; was the branch deleted?",
+                  call. = FALSE)
+          sha <- NA
+        } else {
+          sha <- content$values[[index]]$target$hash
+        }
+      }
+
+      data.frame(
+        stringsAsFactors = FALSE,
+        Package = unname(x[, "Package"]),
+        LibPath = lib,
+        Installed = unname(x[, "RemoteSha"]),
+        Built = gsub(";.*", "", x[, "Built"]),
+        ReposVer = sha,
+        Repository = file.path("https://bitbucket.org",
+                               x[, "RemoteUsername"],
+                               x[, "RemoteRepo"],
+                               "src",
+                               x[, "RemoteRef"])
+      )
+    }))
+  }))
+}
+
 available_updates <- function() {
   cranUpdates <- as.data.frame(old.packages(), stringsAsFactors = FALSE)
   githubUpdates <- githubUpdates()
+  bitbucketUpdates <- bitbucketUpdates()
+
   list(
     CRAN = cranUpdates,
-    GitHub = githubUpdates
+    GitHub = githubUpdates,
+    Bitbucket = bitbucketUpdates
   )
 }

R/bitbucket.R

@@ -0,0 +1,74 @@
+isBitbucketURL <- function(url) {
+  is.string(url) && grepl("^http(?:s)?://(?:www|api).bitbucket.(org|com)", url, perl = TRUE)
+}
+
+canUseBitbucketDownloader <- function() {
+  all(packageVersionInstalled(devtools = "1.9.1", httr = "1.0.0"))
+}
+
+bitbucketDownload <- function(url, destfile, ...) {
+  onError(1, {
+    bitbucket_user  <- bitbucket_user
+    bitbucket_pwd   <- bitbucket_pwd
+    authenticate    <- yoink("httr", "authenticate")
+    GET             <- yoink("httr", "GET")
+    content         <- yoink("httr", "content")
+
+    user <- bitbucket_user(quiet=TRUE)
+    pwd <- bitbucket_pwd(quiet=TRUE)
+    auth <- if (!is.null(user) & !is.null(pwd)) {
+      authenticate(user, pwd, type="basic")
+    } else {
+      list()
+    }
+
+    request <- GET(url, auth)
+    if(request$status == 401) {
+      warning("Failed to download package from Bitbucket: not authorized. ",
+              "Did you set BITBUCKET_USERNAME and BITBUCKET_PASSWORD env vars?",
+              call. = FALSE)
+      return(1)
+    }
+    writeBin(content(request, "raw"), destfile)
+    if (file.exists(destfile)) 0 else 1
+  })
+}
+
+
+#' Retrieve Bitbucket user.
+#'
+#' A bitbucket user
+#' Looks in env var \code{BITBUCKET_USERNAME}
+#'
+#' @keywords internal
+#'
+bitbucket_user <- function(quiet = FALSE) {
+  user <- Sys.getenv("BITBUCKET_USERNAME")
+  if (nzchar(user)) {
+    if (!quiet) {
+      message("Using Bitbucket username from envvar BITBUCKET_USERNAME")
+    }
+    return(user)
+  }
+  return(NULL)
+}
+
+
+#' Retrieve Bitbucket password
+#'
+#' A bitbucket password
+#' Looks in env var \code{BITBUCKET_PASSWORD}
+#'
+#' @keywords internal
+#'
+bitbucket_pwd <- function(quiet = FALSE) {
+  pwd <- Sys.getenv("BITBUCKET_PASSWORD")
+  if (nzchar(pwd)) {
+    if (!quiet) {
+      message("Using Bitbucket password from envvar BITBUCKET_PASSWORD")
+    }
+    return(pwd)
+  }
+  return(NULL)
+}
+

R/cache.R

@@ -34,10 +34,17 @@ hash <- function(path, descLookup = installedDescLookup) {
   }
   pkgName <- DESCRIPTION[["Package"]]
 
+  # Remote SHA backwards compatible with cache v2: use 'GithubSHA1' if exists, otherwise all 'Remote' fields
+  remote_fields <- if ("GithubSHA1" %in% names(DESCRIPTION)) {
+    "GithubSHA1"
+  } else {
+    c("RemoteType", "RemoteHost", "RemoteRepo", "RemoteUsername", "RemoteRef", "RemoteSha", "RemoteSubdir")
+  }
+
   # TODO: Do we want the 'Built' field used for hashing? The main problem with using that is
   # it essentially makes packages installed from source un-recoverable, since they will get
   # built transiently and installed (and so that field could never be replicated).
-  fields <- c("Package", "Version", "GithubSHA1", "Depends", "Imports", "Suggests", "LinkingTo")
+  fields <- c("Package", "Version", remote_fields, "Depends", "Imports", "Suggests", "LinkingTo")
   sub <- DESCRIPTION[names(DESCRIPTION) %in% fields]
 
   # Handle LinkingTo specially -- we need to discover what version of packages in LinkingTo

R/downloader.R

@@ -61,6 +61,13 @@ downloadImpl <- function(url, method, ...) {
       return(result)
   }
 
+  # If this is a path to a Bitbucket URL, attempt to download.
+  if (isBitbucketURL(url) && canUseBitbucketDownloader()) {
+    result <- try(bitbucketDownload(url, ...), silent = TRUE)
+    if (!inherits(result, "try-error"))
+      return(result)
+  }
+
   # When on Windows using an 'internal' method, we need to call
   # 'setInternet2' to set some appropriate state.
   if (is.windows() && method == "internal") {

R/lockfile.R

@@ -282,7 +282,9 @@ aliases <- c(
   RemoteHost = "remote_host",
   RemoteRepo = "remote_repo",
   RemoteUsername = "remote_username",
+  RemoteRef = "remote_ref",
   RemoteSha = "remote_sha",
+  RemoteSubdir = "remote_subdir",
   SourcePath = "source_path",
   Hash = "hash"
 )

R/migrate-library.R

@@ -89,14 +89,17 @@ migrate_packages <- function() {
   githubPkgs <- pkgsToMigrate[sapply(descContent, function(x) {
     "GithubRepo" %in% colnames(x)
   })]
+  bitbucketPkgs <- pkgsToMigrate[sapply(descContent, function(x) {
+    "RemoteType" %in% colnames(x) && x[,"RemoteType"] == "bitbucket"
+  })]
   cranPkgs <- pkgsToMigrate[sapply(descContent, function(x) {
     "Repository" %in% colnames(x) && x[, "Repository"] == "CRAN"
   })]
   biocPkgs <- pkgsToMigrate[sapply(descContent, function(x) {
     "biocViews" %in% colnames(x)
   })]
 
-  unknownPkgs <- setdiff(pkgsToMigrate, c(githubPkgs, cranPkgs, biocPkgs))
+  unknownPkgs <- setdiff(pkgsToMigrate, c(githubPkgs, bitbucketPkgs, cranPkgs, biocPkgs))
 
   # Ignore RStudio packages
   unknownPkgs <- setdiff(unknownPkgs, c("manipulate", "rstudio"))
@@ -118,6 +121,23 @@ migrate_packages <- function() {
     }
   }
 
+  ## Install packages from Bitbucket
+  if (length(bitbucketPkgs)) {
+    message("> Installing Bitbucket packages")
+    if (!requireNamespace("devtools")) {
+      install.packages("devtools", lib = userLib())
+    }
+    for (pkg in bitbucketPkgs) {
+      desc <- as.data.frame(descContent[[pkg]], stringsAsFactors = FALSE)
+      ref <- desc$RemoteSha %||% desc$RemoteRef %||% "master"
+      devtools::install_bitbucket(repo = desc$RemoteRepo,
+                                  username = desc$RemoteUsername,
+                                  ref = ref,
+                                  quick = TRUE
+      )
+    }
+  }
+
   ## Install packages from BioC
   if (length(biocPkgs)) {
     message("> Installing BioC packages")
@@ -148,6 +168,7 @@ migrate_packages <- function() {
     cran = cranPkgs,
     bioc = biocPkgs,
     github = githubPkgs,
+    bitbucket = bitbucketPkgs,
     missing = setdiff(failures, c("rstudio", "manipulate"))
   )
 

R/packrat.R

@@ -402,7 +402,7 @@ restore <- function(project = NULL,
     options(repos = externalRepos)
   }, add = TRUE)
 
-  # Install each package from CRAN or github, from binaries when available and
+  # Install each package from CRAN or github/bitbucket, from binaries when available and
   # then from sources.
   restoreImpl(project, repos, packages, libDir,
               pkgsToIgnore = pkgsToIgnore, prompt = prompt,

R/pkg.R

@@ -284,7 +284,7 @@ getPackageRecords <- function(pkgNames,
 }
 
 # Reads a description file and attempts to infer where the package came from.
-# Currently works only for packages installed from CRAN or from GitHub using
+# Currently works only for packages installed from CRAN or from GitHub/Bitbucket using
 # devtools 1.4 or later.
 inferPackageRecord <- function(df) {
   name <- as.character(df$Package)
@@ -306,6 +306,19 @@ inferPackageRecord <- function(df) {
       c(remote_username = as.character(df$RemoteUsername)),
       c(remote_sha = as.character(df$RemoteSha))
     ), class = c('packageRecord', 'github')))
+  } else if (!is.null(df$RemoteType) && df$RemoteType == "bitbucket") {
+    # It's Bitbucket!
+    return(structure(c(list(
+      name = name,
+      source = 'bitbucket',
+      version = ver,
+      remote_repo = as.character(df$RemoteRepo),
+      remote_username = as.character(df$RemoteUsername),
+      remote_ref = as.character(df$RemoteRef),
+      remote_sha = as.character(df$RemoteSha)),
+      c(remote_host = as.character(df$RemoteHost)),
+      c(remote_subdir = as.character(df$RemoteSubdir))
+    ), class = c('packageRecord', 'bitbucket')))
   } else if (identical(as.character(df$Priority), 'base')) {
     # It's a base package!
     return(NULL)