1#' Install a remote package.
2#'
3#' This:
4#' \enumerate{
5#'   \item downloads source bundle
6#'   \item decompresses & checks that it's a package
7#'   \item adds metadata to DESCRIPTION
8#'   \item calls install
9#' }
10#'
11#' It uses the additional S3 generic functions to work. Writing methods for
12#' these functions would allow 3rd party packages to define custom remotes.
13#' @inheritParams install_github
14#' @keywords internal
15#' @export
16install_remote <- function(remote,
17                           dependencies,
18                           upgrade,
19                           force,
20                           quiet,
21                           build,
22                           build_opts,
23                           build_manual,
24                           build_vignettes,
25                           repos,
26                           type,
27                           ...) {
28
29  stopifnot(is.remote(remote))
30
31  package_name <- remote_package_name(remote)
32  local_sha <- local_sha(package_name)
33  remote_sha <- remote_sha(remote, local_sha)
34
35  if (!isTRUE(force) &&
36    !different_sha(remote_sha = remote_sha, local_sha = local_sha)) {
37
38    if (!quiet) {
39      message(
40        "Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,",
41        " the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n",
42        "  Use `force = TRUE` to force installation")
43    }
44    return(invisible(package_name))
45  }
46
47  if (inherits(remote, "cran_remote")) {
48    install_packages(
49      package_name, repos = remote$repos, type = remote$pkg_type,
50      dependencies = dependencies,
51      quiet = quiet,
52      ...)
53    return(invisible(package_name))
54  }
55
56  res <- try(bundle <- remote_download(remote, quiet = quiet), silent = quiet)
57  if (inherits(res, "try-error")) {
58    return(NA_character_)
59  }
60
61  on.exit(unlink(bundle), add = TRUE)
62
63  source <- source_pkg(bundle, subdir = remote$subdir)
64  on.exit(unlink(source, recursive = TRUE), add = TRUE)
65
66  update_submodules(source, remote$subdir, quiet)
67
68  add_metadata(source, remote_metadata(remote, bundle, source, remote_sha))
69
70  # Because we've modified DESCRIPTION, its original MD5 value is wrong
71  clear_description_md5(source)
72
73  install(source,
74          dependencies = dependencies,
75          upgrade = upgrade,
76          force = force,
77          quiet = quiet,
78          build = build,
79          build_opts = build_opts,
80          build_manual = build_manual,
81          build_vignettes = build_vignettes,
82          repos = repos,
83          type = type,
84          ...)
85}
86
87install_remotes <- function(remotes, ...) {
88  res <- character(length(remotes))
89  for (i in seq_along(remotes)) {
90    tryCatch(
91      res[[i]] <- install_remote(remotes[[i]], ...),
92      error = function(e) {
93        stop(remote_install_error(remotes[[i]], e))
94      })
95  }
96  invisible(res)
97}
98
99remote_install_error <- function(remote, error) {
100  msg <- sprintf(
101    "Failed to install '%s' from %s:\n  %s", remote_name_or_unknown(remote), format(remote), conditionMessage(error)
102  )
103
104 structure(list(message = msg, call = NULL, error = error, remote = remote), class = c("install_error", "error", "condition"))
105}
106
107remote_name_or_unknown <- function(remote) {
108  res <- tryCatch(
109    res <- remote_package_name(remote),
110    error = function(e) NA_character_)
111
112  if (is.na(res)) {
113    return("unknown package")
114  }
115
116  res
117}
118
119#' @rdname install_remote
120#' @export
121#' @keywords internal
122add_metadata <- function(pkg_path, meta) {
123
124  # During installation, the DESCRIPTION file is read and an package.rds file
125  # created with most of the information from the DESCRIPTION file. Functions
126  # that read package metadata may use either the DESCRIPTION file or the
127  # package.rds file, therefore we attempt to modify both of them
128  source_desc <- file.path(pkg_path, "DESCRIPTION")
129  binary_desc <- file.path(pkg_path, "Meta", "package.rds")
130  if (file.exists(source_desc)) {
131    desc <- read_dcf(source_desc)
132
133    desc <- utils::modifyList(desc, meta)
134
135    write_dcf(source_desc, desc)
136  }
137
138  if (file.exists(binary_desc)) {
139    pkg_desc <- base::readRDS(binary_desc)
140    desc <- as.list(pkg_desc$DESCRIPTION)
141    desc <- utils::modifyList(desc, meta)
142    pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc))
143    base::saveRDS(pkg_desc, binary_desc)
144  }
145}
146
147# Modify the MD5 file - remove the line for DESCRIPTION
148clear_description_md5 <- function(pkg_path) {
149  path <- file.path(pkg_path, "MD5")
150
151  if (file.exists(path)) {
152    text <- readLines(path)
153    text <- text[!grepl(".*\\*DESCRIPTION$", text)]
154
155    writeLines(text, path)
156  }
157}
158
159remote <- function(type, ...) {
160  structure(list(...), class = c(paste0(type, "_remote"), "remote"))
161}
162
163is.remote <- function(x) inherits(x, "remote")
164
165#' @rdname install_remote
166#' @keywords internal
167#' @export
168remote_download <- function(x, quiet = FALSE) UseMethod("remote_download")
169
170#' @rdname install_remote
171#' @keywords internal
172#' @export
173remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata")
174
175#' @rdname install_remote
176#' @keywords internal
177#' @export
178remote_package_name <- function(remote, ...) UseMethod("remote_package_name")
179
180#' @rdname install_remote
181#' @keywords internal
182#' @export
183remote_sha <- function(remote, ...) UseMethod("remote_sha")
184
185remote_package_name.default <- function(remote, ...) remote$repo
186remote_sha.default <- function(remote, ...) NA_character_
187
188different_sha <- function(remote_sha, local_sha) {
189
190  same <- remote_sha == local_sha
191  same <- isTRUE(same) && !is.na(same)
192  !same
193}
194
195local_sha <- function(name) {
196  package2remote(name)$sha %||% NA_character_
197}
198
199# Convert an installed package to its equivalent remote. This constructs the
200# remote from metadata stored in the package's DESCRIPTION file; the metadata
201# is added to the package when it is installed by remotes. If the package is
202# installed some other way, such as by `install.packages()` there will be no
203# meta-data, so there we construct a generic CRAN remote.
204package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) {
205
206  x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA)
207
208  # will be NA if not installed
209  if (identical(x, NA)) {
210    return(remote("cran",
211        name = name,
212        repos = repos,
213        pkg_type = type,
214        sha = NA_character_))
215  }
216
217  if (is.null(x$RemoteType) || x$RemoteType == "cran") {
218
219    # Packages installed with install.packages() or locally without remotes
220    return(remote("cran",
221        name = x$Package,
222        repos = repos,
223        pkg_type = type,
224        sha = x$Version))
225  }
226
227  switch(x$RemoteType,
228    standard = remote("cran",
229      name = x$Package,
230      repos = x$RemoteRepos %||% repos,
231      pkg_type = x$RemotePkgType %||% type,
232      sha = x$RemoteSha),
233    github = remote("github",
234      host = x$RemoteHost,
235      package = x$RemotePackage,
236      repo = x$RemoteRepo,
237      subdir = x$RemoteSubdir,
238      username = x$RemoteUsername,
239      ref = x$RemoteRef,
240      sha = x$RemoteSha,
241      auth_token = github_pat()),
242    gitlab = remote("gitlab",
243      host = x$RemoteHost,
244      repo = x$RemoteRepo,
245      subdir = x$RemoteSubdir,
246      username = x$RemoteUsername,
247      ref = x$RemoteRef,
248      sha = x$RemoteSha,
249      auth_token = gitlab_pat()),
250    xgit = remote("xgit",
251      url = trim_ws(x$RemoteUrl),
252      ref = x$RemoteRef %||% x$RemoteBranch,
253      sha = x$RemoteSha,
254      subdir = x$RemoteSubdir,
255      args = x$RemoteArgs),
256    git2r = remote("git2r",
257      url = trim_ws(x$RemoteUrl),
258      ref = x$RemoteRef %||% x$RemoteBranch,
259      sha = x$RemoteSha,
260      subdir = x$RemoteSubdir,
261      credentials = git_credentials()),
262    bitbucket = remote("bitbucket",
263      host = x$RemoteHost,
264      repo = x$RemoteRepo,
265      username = x$RemoteUsername,
266      ref = x$RemoteRef,
267      sha = x$RemoteSha,
268      subdir = x$RemoteSubdir,
269      auth_user = bitbucket_user(),
270      password = bitbucket_password()),
271    svn = remote("svn",
272      url = trim_ws(x$RemoteUrl),
273      svn_subdir = x$RemoteSubdir,
274      revision = x$RemoteSha,
275      args = x$RemoteArgs),
276    local = remote("local",
277      path = {
278        path <- trim_ws(x$RemoteUrl)
279        if (length(path) == 0) {
280          path <- parse_pkg_ref(x$RemotePkgRef)$ref
281        }
282        path
283      },
284      subdir = x$RemoteSubdir,
285      sha = {
286        # Packages installed locally might have RemoteSha == NA_character_
287        x$RemoteSha %||% x$Version
288      }),
289    url = remote("url",
290      url = trim_ws(x$RemoteUrl),
291      subdir = x$RemoteSubdir,
292      config = x$RemoteConfig,
293      pkg_type = x$RemotePkgType %||% type),
294    bioc_git2r = remote("bioc_git2r",
295      mirror = x$RemoteMirror,
296      repo = x$RemoteRepo,
297      release = x$RemoteRelease,
298      sha = x$RemoteSha,
299      branch = x$RemoteBranch),
300    bioc_xgit = remote("bioc_xgit",
301      mirror = x$RemoteMirror,
302      repo = x$RemoteRepo,
303      release = x$RemoteRelease,
304      sha = x$RemoteSha,
305      branch = x$RemoteBranch),
306    stop(sprintf("can't convert package %s with RemoteType '%s' to remote", name, x$RemoteType))
307  )
308}
309
310parse_pkg_ref <- function(x) {
311  res <- re_match(x, "(?<type>[^:]+)::(?<ref>.*)")
312  if (is.na(res$ref)) {
313    stop("Invalid package reference:\n  ", x, call. = FALSE)
314  }
315  res
316}
317
318#' @export
319format.remotes <- function(x, ...) {
320  vapply(x, format, character(1))
321}
322