src/library/pkgdepends/R/type-url.R

In pak: Another Approach to Package Installation

# -----------------------------------------------------------------------
# API

parse_remote_url <- function(specs, config, ...) {
  parsed_specs <- re_match(specs, type_url_rx())
  parsed_specs$ref <- parsed_specs$.text
  cn <- setdiff(colnames(parsed_specs), c(".match", ".text"))
  parsed_specs <- parsed_specs[, cn]
  parsed_specs$type <- "url"
  parsed_specs$hash <- vcapply(specs, url_hash)
  parsed_specs$package[parsed_specs$package == ""] <- NA_character_

  # Special case downloads from GH
  parsed_gh_specs <- re_match(specs, type_github_download_url_rx())
  parsed_specs$package <- ifelse(
    is.na(parsed_specs$package) & !is.na(parsed_gh_specs$repo),
    parsed_gh_specs$repo,
    parsed_specs$package
  )

  lapply(
    seq_len(nrow(parsed_specs)),
    function(i) as.list(parsed_specs[i,])
  )
}

resolve_remote_url <- function(remote, direct, config, cache,
                               dependencies, ...) {

  remote; direct; config; cache; dependencies; list(...)
  nocache <- is_true_param(remote$params, "nocache")
  type_url_resolve(remote, cache, config, direct = direct,
                   dependencies = dependencies[[2 - direct]],
                   nocache = nocache)$
    then(function(x) x$resolution)
}

download_remote_url <- function(resolution, target, target_tree, config,
                                cache, which, on_progress) {

  resolution; target; target_tree; config; cache; which; on_progress

  remote <- resolution$remote[[1]]
  packaged <- resolution$metadata[[1]][["RemotePackaged"]]
  tmpd <- type_url_tempdir(remote, config)

  rimraf(c(target, target_tree))

  status <- NULL

  # If we are installing an install plan, then it might not be there
  nocache <- is_true_param(resolution$params[[1]], "nocache")
  if (!file.exists(tmpd$ok)) {
    dx <- type_url_resolve(remote, cache, config, nocache)$
      then(function(x) {
        newres <- x$resolution
        status <<- x$data$status
        res_etag <- resolution$metadata[[1]][["RemoteEtag"]]
        new_etag <- newres$metadata[["RemoteEtag"]]
        if (res_etag != new_etag) {
          warning("Package file at `", remote$url, "` has changed") # nocov
        }
      })
  } else {
    status <- "Had"
    dx <- async_constant(0)
  }

  dx$
    then(function() {
      if (packaged == "TRUE") {
        mkdirp(dirname(target))
        if (!file.copy(tmpd$archive, target, overwrite = TRUE)) {
          throw(pkg_error(
            "Failed to copy package from {.path {tmpd$archive}} to
             {.path{ target}}.",
            i = "It was downloaded from {.url {remote$url}}."
          ))
        }
      } else {
        mkdirp(target_tree)
        if (!file.copy(tmpd$extract, target_tree, recursive = TRUE)) {
          throw(pkg_error(                                    # nocov start
            "Failed to copy package from {.path {tmpd$archive}} to
             {.path{ target}}.",
            i = "It was downloaded from {.url {remote$url}}."
          ))                                                  # nocov end
        }
      }
    })$
    then(function() status)
}

satisfy_remote_url <- function(resolution, candidate, config, ...) {
  ## 1. package name must match
  if (resolution$package != candidate$package) {
    return(structure(FALSE, reason = "Package names differ"))
  }

  ## 2. installed ref is good, if it has the same etag
  if (candidate$type == "installed") {
    want_reinst <- is_true_param(resolution$params[[1]], "reinstall")
    if (want_reinst) {
      return(structure(FALSE, reason = "Re-install requested"))
    }
    t1 <- tryCatch(candidate$extra[[1]]$remoteetag, error = function(e) "")
    t2 <- resolution$metadata[[1]][["RemoteEtag"]]
    ok <- is_string(t1) && is_string(t2) && t1 == t2
    if (!ok) {
      return(structure(FALSE, reason = "Installed URL etag mismatch"))
    } else {
      return(TRUE)
    }
  }

  ## 3. same url is good
  if (candidate$type == "url") {
    if (resolution$ref == candidate$ref) return(TRUE)
    return(structure(FALSE, reason = "URL mismatch"))
  }

  structure(FALSE, reason = "Repo type mismatch")
}

installedok_remote_url <- function(installed, solution, config, ...) {
  identical(installed$package, solution$package) &&
    identical(installed$version, solution$version) &&
    identical(installed[["remotetype"]], "url") &&
    identical(installed[["remoteetag"]], solution$metadata[[1]][["RemoteEtag"]])
}

# -----------------------------------------------------------------------
# Internal functions

type_url_rx <- function() {
  paste0(
    "^",
    ## Optional package name
    "(?:(?<package>", package_name_rx(), ")=)?",
    "(?:url::)",
    "(?<url>.*)",
    "$"
  )
}

url_hash <- function(x) {
  cli::hash_obj_md5(x)
}

# E.g. url::https://github.com/r-lib/tidyselect/archive/main.tar.gz

type_github_download_url_rx <- function() {
  paste0(
    "^",
    "(?:url::)",
    "https://github.com/",
    github_username_rx(), "/",
    github_repo_rx(),
    "/archive/",
    "(?<branch>[^/.]+)",
    "[.]tar[.]gz$"
  )
}

type_url_tempdir <- function(remote, config) {
  base <- basename(remote$url)
  filename <- paste0(substr(remote$hash, 1, 7), "-", basename(remote$url))
  archive <- file.path(config$get("cache_dir"), filename)
  extract <- file.path(config$get("cache_dir"), paste0(filename, "-t"))
  ok <- file.path(config$get("cache_dir"), paste0(filename, "-ok"))
  list(
    archive = archive,
    extract = extract,
    cachepath = file.path("archives", filename),
    ok = ok
  )
}

type_url_download_and_extract <- function(remote, cache, config, tmpd,
                                          nocache) {
  id <- NULL
  tmpd <- tmpd
  async_constant(if (nocache) {
    mkdirp(dirname(tmpd$archive))
    download_one_of(remote$url, tmpd$archive)$
      then(function(dl) { attr(dl, "action") <- "Got"; dl })
  } else {
    cache$package$async_update_or_add(
      tmpd$archive,
      remote$url,
      path = tmpd$cachepath,
      http_headers = default_download_headers(remote$url)
    )
  })$then(function(dl) {
    tmpd$status <<- attr(dl, "action")
    tmpd$etag <<- if (is.na(dl$etag)) substr(dl$sha256, 1, 16) else dl$etag
    tmpd$id <<- cli::hash_obj_md5(tmpd$etag)
    rimraf(c(tmpd$extract, tmpd$ok))
    mkdirp(tmpd$extract)
    run_uncompress_process(tmpd$archive, tmpd$extract)

  })$then(function(status) {
    tmpd$pkgdir <<- get_pkg_dir_from_archive_dir(tmpd$extract)
    cat("ok\n", file = tmpd$ok)
    tmpd
  })
}

type_url_resolve <- function(remote, cache, config, direct = FALSE,
                             dependencies = character(), nocache = FALSE) {
  tmpd <- type_url_tempdir(remote, config)
  xdirs <- NULL
  type_url_download_and_extract(remote, cache, config, tmpd, nocache)$
    then(function(dirs) {
      xdirs <<- dirs
      resolve_from_description(
        path = dirs$pkgdir,
        sources = remote$url,
        remote = remote,
        direct = direct,
        config = config,
        cache = cache,
        dependencies = dependencies
      )
    })$
    then(function(x) {
      x$target <- file.path(
        "src/contrib",
        paste0(x$package, "_", x$version, "-",
               substr(xdirs$id, 1, 10), ".tar.gz")
      )
      x$metadata[["RemoteEtag"]] <- xdirs$etag
      x$extra[[1]][["resolve_download_status"]] <- tmpd$status
      x$metadata[["RemotePackaged"]] <-
        x$extra[[1]]$description$has_fields("Packaged")
      x$params[[1]] <- remote$params
      list(resolution = x, data = xdirs)
    })
}


get_pkg_dir_from_archive_dir <- function(x) {
  top <- dir(x)
  if (length(top) != 1) {
    throw(pkg_error(
      "Package archive at {.path {x}} should contain exactly one directory.",
      i = "It has {cli::no(length(top))} file{?s}/director{?y/ies}:
       {.path {top}}"
    ))
  }
  file.path(x, top)
}