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

parse_remote_github <- function(specs, config, ...) {
  pds <- re_match(specs, github_rx())
  if (any(unk <- is.na(pds$.match))) {
    pds[unk] <- re_match(specs[unk], github_url_rx())
    pds[unk, "subdir"] <- ""
  }

  pds$ref <- pds$.text
  cn <- setdiff(colnames(pds), c(".match", ".text"))
  pds <- pds[, cn]
  pds$type <- "github"
  pds$package <- ifelse(nzchar(pds$package), pds$package, pds$repo)
  lapply(
    seq_len(nrow(pds)),
    function(i) as.list(pds[i, ])
  )
}

resolve_remote_github <- function(
  remote,
  direct,
  config,
  cache,
  dependencies,
  ...
) {
  force(direct)
  force(dependencies)
  ## Get the DESCRIPTION data, and the SHA we need
  type_github_get_data(remote)$then(function(resp) {
    data <- list(
      desc = resp$description,
      sha = resp$sha,
      remote = remote,
      direct = direct,
      dependencies = dependencies[[2 - direct]]
    )
    type_github_make_resolution(data)
  })
}

download_remote_github <- function(
  resolution,
  target,
  target_tree,
  config,
  cache,
  which,
  on_progress
) {
  ## A GitHub package needs to be built, from the downloaded repo
  ## If we are downloading a solution, then we skip building the vignettes,
  ## because these will be built later by pkginstall.
  ##
  ## We cache both the downloaded repo snapshot and the built package in
  ## the package cache. So this is how we go:
  ##
  ## 1. If there is a locally built bianry in the cache (including
  ##    vignettes if they are requested), then we use that.
  ## 2. If there is a built package in the cache (including vignettes
  ##    if they are needed), then we use that.
  ## 3. If there is a repo snapshot in the cache, we build an R package
  ##    from it. (Add also add it to the cache.)
  ## 4. Otherwise we download the repo, add it to the cache, build the
  ##    R package, and add that to the cache as well.

  package <- resolution$package
  sha <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
  need_vignettes <- which == "resolution"
  nocache <- is_true_param(resolution$params[[1]], "nocache")
  source <- is_true_param(resolution$params[[1]], "source")

  # in case there is a leftover package/tree here
  unlink(c(target, target_tree), recursive = TRUE)

  ## 1. Check for a binary package

  if (!nocache && !source) {
    ptfm <- current_r_platform()
    hit <- cache$package$copy_to(
      target,
      package = package,
      sha256 = sha,
      built = TRUE,
      platform = ptfm,
      rversion = current_r_version(),
      .list = c(if (need_vignettes) c(vignettes = TRUE))
    )

    if (nrow(hit)) {
      return(paste("Had", ptfm)) # TODO: untested currently
    }
  }

  ## 2. Check if we have a built package in the cache. We do not check the
  ## ref or the type, so the package could have been built from a local
  ## ref or from another repo. As long as the sha is the same, we are
  ## fine. If we don't require vignetted, then a package with or without
  ## vignettes is fine.

  if (!nocache) {
    hit <- cache$package$copy_to(
      target,
      package = package,
      sha256 = sha,
      built = TRUE,
      .list = c(if (need_vignettes) c(vignettes = TRUE))
    )
    if (nrow(hit)) {
      "!DEBUG found GH `resolution$ref`@`sha` in the cache"
      return("Had")
    }
  }

  ## 3. Check if we have a repo snapshot in the cache.

  rel_target <- resolution$target
  if (!nocache) {
    subdir <- resolution$remote[[1]]$subdir
    hit <- cache$package$copy_to(
      target_tree,
      package = package,
      sha256 = sha,
      built = FALSE
    )
    if (nrow(hit)) {
      "!DEBUG found GH zip for `resolution$ref`@`sha` in the cache"
      return("Had")
    }
  }

  ## 4. Need to download the repo

  "!DEBUG Need to download GH package `resolution$ref`@`sha`"
  urls <- resolution$sources[[1]]
  rel_zip <- paste0(rel_target, "-t")
  type_github_download_repo(
    urls,
    target_tree,
    rel_zip,
    sha,
    package,
    cache,
    on_progress,
    nocache
  )$then(function() {
    "!DEBUG Building package `resolution$package`"
    return("Got")
  })
}

type_github_download_repo <- function(
  urls,
  repo_zip,
  rel_zip,
  sha,
  package,
  cache,
  on_progress,
  nocache
) {
  urls
  repo_zip
  sha
  package
  cache
  on_progress
  nocache
  ## TODO: progress
  headers <- type_github_get_headers()
  download_file(
    urls,
    repo_zip,
    on_progress = on_progress,
    headers = headers
  )$then(function() {
    if (!nocache) {
      cache$package$add(
        repo_zip,
        rel_zip,
        package = package,
        sha = sha,
        built = FALSE
      )
    }
    "Got"
  })
}

## ----------------------------------------------------------------------

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

  ## 1. installed ref is good, if it has the same sha
  if (candidate$type == "installed") {
    want_reinst <- is_true_param(resolution$params[[1]], "reinstall")
    if (want_reinst) {
      return(structure(FALSE, reason = "Re-install requested"))
    }
    sha1 <- candidate$extra[[1]][["remotesha"]] %||% NA_character_
    sha2 <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
    ok <- is_string(sha1) && is_string(sha2) && same_sha(sha1, sha2)
    if (!ok) {
      return(structure(FALSE, reason = "Installed package sha mismatch"))
    } else {
      return(TRUE)
    }
  }

  ## 2. local packages satisfy a GH remote
  ## See https://github.com/r-lib/pkgdepends/issues/229
  if (candidate$type == "local") {
    return(TRUE)
  }

  ## 3. other refs are also good, as long as they have the same sha
  sha1 <- (if (is.list(candidate$extra[[1]])) {
    candidate$extra[[1]][["remotesha"]]
  }) %||%
    NA_character_
  sha2 <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
  ok <- is_string(sha1) && is_string(sha2) && same_sha(sha1, sha2)
  if (!ok) {
    return(structure(FALSE, reason = "Candidate package sha mismatch"))
  } else {
    return(TRUE)
  }
}

installedok_remote_github <- function(installed, solution, config, ...) {
  identical(installed$package, solution$package) &&
    identical(installed$version, solution$version) &&
    identical(installed[["remotesha"]], solution$metadata[[1]][["RemoteSha"]])
}

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

type_github_builtin_token <- function() {
  pats <- c(
    paste0("3687d8b", "b0556b7c3", "72ba1681d", "e5e689b", "3ec61279"),
    paste0("8ffecf5", "13a136f3d", "23bfe46c4", "2d67b3c", "966baf7b")
  )
  once_per_session(cli::cli_alert_warning(c(
    "Using bundled GitHub PAT. ",
    "Please add your own PAT using {.code gitcreds::gitcreds_set()}."
  )))
  sample(pats, 1)
}

type_github_get_headers <- function() {
  headers <- c(
    "Accept" = "application/vnd.github.v3+json",
    "Content-Type" = "application/json; charset=utf-8"
  )

  token <- NA_character_
  if (Sys.getenv("CI", "") != "") {
    token <- Sys.getenv("CI_GITHUB_TOKEN", NA_character_)
  }
  if (is.na(token)) {
    token <- tryCatch(
      gitcreds_get()$password,
      error = function(e) NA_character_
    )
  }
  if (is.na(token)) {
    token <- type_github_builtin_token()
  }
  headers <- c(headers, c("Authorization" = paste("token", token)))

  headers <- c(headers, c("User-Agent" = "r-lib/pak"))
  headers
}

type_github_get_data <- function(rem) {
  dx <- if (!is.null(rem$pull) && rem$pull != "") {
    type_github_get_data_pull(rem)
  } else if (!is.null(rem$release) && rem$release != "") {
    type_github_get_data_release(rem)
  } else {
    type_github_get_data_ref(rem)
  }

  dx$then(function(data) {
    chain_error(
      dsc <- desc::desc(text = data$desc),
      new_github_baddesc_error(rem, call)
    )
    list(sha = data$sha, description = dsc)
  })
}

type_github_get_data_ref <- function(rem) {
  user <- rem$username
  repo <- rem$repo
  ref <- rem$commitish %|z|% "HEAD"
  subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")

  query <- sprintf(
    "{
    repository(owner: \"%s\", name: \"%s\") {
      description: object(expression: \"%s:%sDESCRIPTION\") {
        ... on Blob {
          isBinary
          text
        }
      }
      sha: object(expression: \"%s\") {
        oid
      }
    }
  }",
    user,
    repo,
    ref,
    subdir,
    ref
  )

  github_query(query)$then(function(resp) {
    check_github_response_ref(resp$response, resp$obj, rem, call. = call)
  })$then(function(obj) {
    list(
      sha = obj[[c("data", "repository", "sha", "oid")]],
      desc = obj[[c("data", "repository", "description", "text")]]
    )
  })
}

check_github_response_ref <- function(resp, obj, rem, call.) {
  if (!is.null(obj$errors)) {
    throw(new_github_query_error(rem, resp, obj, call.))
  }
  if (isTRUE(obj[[c("data", "repository", "description", "isBinary")]])) {
    throw(new_github_baddesc_error(rem, call.))
  }
  if (is.null(obj[[c("data", "repository", "sha")]])) {
    throw(new_github_noref_error(rem, call.))
  }
  if (is.null(obj[[c("data", "repository", "description", "text")]])) {
    throw(new_github_no_package_error(rem, call.))
  }
  obj
}

type_github_get_data_pull <- function(rem) {
  call <- sys.call(-1)
  user <- rem$username
  repo <- rem$repo
  pull <- rem$pull
  subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")

  query <- sprintf(
    "{
    repository(owner: \"%s\", name: \"%s\") {
      pullRequest(number: %s) {
        headRefOid
        headRef {
          target {
            ... on Commit {
              file(path: \"%sDESCRIPTION\") {
                object {
                  ... on Blob {
                    isBinary
                    text
                  }
                }
              }
            }
          }
        }
      }
    }
  }",
    user,
    repo,
    pull,
    subdir
  )

  github_query(query)$then(function(resp) {
    check_github_response_pull(resp$response, resp$obj, rem, call. = call)
  })$then(function(obj) {
    ref <- obj[[c("data", "repository", "pullRequest", "headRefOid")]]
    txt <- obj[[c(
      "data",
      "repository",
      "pullRequest",
      "headRef",
      "target",
      "file",
      "object",
      "text"
    )]]
    list(sha = ref, desc = txt)
  })
}

check_github_response_pull <- function(resp, obj, rem, call.) {
  if (!is.null(obj$errors)) {
    throw(new_github_query_error(rem, resp, obj, call.))
  }
  # No full coverage here, because unless something goes super wrong,
  # these cases almost never happen.
  if (!is.null(obj$errors)) {
    throw(new_github_query_error(rem, resp, obj, call.)) # nocov
  }

  if (
    isTRUE(obj[[c(
      "data",
      "repository",
      "pullRequest",
      "headRef",
      "target",
      "file",
      "object",
      "isBinary"
    )]])
  ) {
    throw(new_github_baddesc_error(rem, call.)) # nocov
  }
  if (
    is.null(obj[[c(
      "data",
      "repository",
      "pullRequest",
      "headRef",
      "target",
      "file",
      "object"
    )]])
  ) {
    throw(new_github_no_package_error(rem, call.))
  }
  obj
}

type_github_get_data_release <- function(rem) {
  call <- sys.call(-1)
  user <- rem$username
  repo <- rem$repo
  ref <- NULL
  subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")

  query <- sprintf(
    "{
    repository(owner: \"%s\", name:\"%s\") {
      latestRelease {
        tagName
        tagCommit {
          oid,
          file(path: \"%sDESCRIPTION\") {
            object {
              ... on Blob {
                isBinary
                text
              }
            }
          }
        }
      }
    }
  }",
    user,
    repo,
    subdir
  )

  github_query(query)$then(function(resp) {
    check_github_response_release(resp$response, resp$obj, rem, call. = call)
  })$then(function(obj) {
    ref <- obj[[c("data", "repository", "latestRelease", "tagCommit", "oid")]]
    txt <- obj[[c(
      "data",
      "repository",
      "latestRelease",
      "tagCommit",
      "file",
      "object",
      "text"
    )]]
    list(sha = ref, desc = txt)
  })
}

check_github_response_release <- function(resp, obj, rem, call.) {
  if (!is.null(obj$errors)) {
    throw(new_github_query_error(rem, resp, obj, call.))
  }
  if (is.null(obj[[c("data", "repository", "latestRelease")]])) {
    throw(new_github_no_release_error(rem, call.))
  }
  if (
    isTRUE(obj[[c(
      "data",
      "repository",
      "latestRelease",
      "tagCommit",
      "file",
      "object",
      "isBinary"
    )]])
  ) {
    throw(new_github_baddesc_error(rem, call.))
  }
  if (
    is.null(obj[[c(
      "data",
      "repository",
      "latestRelease",
      "tagCommit",
      "file",
      "object"
    )]])
  ) {
    throw(new_github_no_package_error(rem, call.))
  }
  obj
}

type_github_make_resolution <- function(data) {
  deps <- resolve_ref_deps(
    data$desc$get_deps(),
    data$desc$get("Remotes"),
    data$desc$get(extra_config_fields(data$desc$fields()))
  )

  url <- Sys.getenv("R_PKG_GITHUB_API_URL", "https://api.github.com")
  proto <- sub(":.*$", "", url)
  host <- sub("^[^:]*://", "", url)
  sha <- data$sha
  sha7 <- substr(sha, 1, 7)
  username <- data$remote$username
  repo <- data$remote$repo
  subdir <- data$remote$subdir %|z|% NULL
  commitish <- data$remote$commitish %|z|% NULL
  pull <- data$remote$pull %|z|% NULL
  release <- data$remote$release %|z|% NULL
  package <- data$desc$get_field("Package")
  version <- data$desc$get_field("Version")
  dependencies <- data$dependencies
  unknown <- deps$ref[deps$type %in% dependencies]
  unknown <- setdiff(unknown, c(base_packages(), "R"))

  meta <- c(
    RemoteType = "github",
    RemoteHost = host,
    RemoteRepo = repo,
    RemoteUsername = username,
    RemotePkgRef = data$remote$ref,
    RemoteRef = if (is.null(pull)) commitish %||% "HEAD" else NULL,
    RemotePull = pull,
    RemoteSha = sha,
    RemoteSubdir = subdir,
    GithubRepo = repo,
    GithubUsername = username,
    GithubRef = if (is.null(pull)) commitish %||% "HEAD" else NULL,
    GitHubPull = pull,
    GithubSHA1 = sha,
    GithubSubdir = subdir
  )

  list(
    ref = data$remote$ref,
    type = data$remote$type,
    direct = data$direct,
    status = "OK",
    package = package,
    version = version,
    license = data$desc$get_field("License", NA_character_),
    sources = sprintf(
      "%s://%s/repos/%s/%s/zipball/%s",
      proto,
      host,
      username,
      repo,
      sha
    ),
    target = sprintf("src/contrib/%s_%s_%s.tar.gz", package, version, sha7),
    remote = list(data$remote),
    deps = list(deps),
    unknown_deps = unknown,
    extra = list(list(remotesha = sha)),
    metadata = meta,
    params = data$remote$params,
    sysreqs = data$desc$get_field("SystemRequirements", "")
  )
}

github_query <- function(
  query,
  url = paste0(
    Sys.getenv("R_PKG_GITHUB_API_URL", "https://api.github.com"),
    "/graphql"
  ),
  headers = character(),
  ...
) {
  query
  url
  headers
  list(...)

  headers <- c(headers, type_github_get_headers())
  data <- tojson$write_str(
    list(query = query),
    opts = list(auto_unbox = TRUE)
  )
  resp <- NULL
  obj <- NULL

  http_post(url, data = data, headers = headers, ...)$catch(
    error = function(err) throw(new_github_offline_error())
  )$then(function(res) {
    resp <<- res
    json <- rawToChar(res$content %||% raw())
    obj <<- if (nzchar(json)) jsonlite::fromJSON(json, simplifyVector = FALSE)
    res
  })$then(http_stop_for_status)$catch(async_http_error = function(err) {
    throw(new_github_http_error(resp, obj), parent = err)
  })$then(function(res) {
    list(response = resp, obj = obj)
  })
}

# -----------------------------------------------------------------------
# Errors

new_github_error <- function(..., call. = NULL) {
  cond <- new_error(..., call. = call.)
  class(cond) <- c("github_error", class(cond))
  cond
}

# No internet?

new_github_offline_error <- function(call. = NULL) {
  new_github_error("Cannot query GitHub, are you offline?", call. = call.)
}

# HTTP error

new_github_http_error <- function(response, obj, call. = NULL) {
  if (
    response$status_code == 401 &&
      nzchar(obj$message) &&
      grepl("Bad credentials", obj$message)
  ) {
    return(new_github_badpat_error(call. = call.))
  }
  new_github_error("GitHub HTTP error", call. = call.)
}

# Error in a query

new_github_query_error <- function(rem, response, obj, call. = NULL) {
  if ("RATE_LIMITED" %in% vcapply(obj$errors, "[[", "type")) {
    return(new_github_ratelimited_error(response, obj, call. = NULL))

    # we don't actually get this response currently
  } else if (
    grepl("Could not resolve to a User", vcapply(obj$errors, "[[", "message"))
  ) {
    return(new_github_nouser_error(rem, obj, call. = call.)) # nocov
  } else if (
    grepl(
      "Could not resolve to a Repository",
      vcapply(obj$errors, "[[", "message")
    )
  ) {
    return(new_github_norepo_error(rem, obj, call. = call.))
  } else if (
    grepl(
      "Could not resolve to a PullRequest",
      vcapply(obj$errors, "[[", "message")
    )
  ) {
    return(new_github_nopr_error(rem, obj, call. = call.))
  }

  # Otherwise some generic code
  ghmsgs <- sub("\\.?$", ".", vcapply(obj$errors, "[[", "message")) # nocov
  msg <- paste0("GitHub error: ", paste0(ghmsgs, collapse = ", ")) # nocov
  new_github_error(msg, call. = call.) # nocov
}

# No such user/org

new_github_nouser_error <- function(rem, obj, call. = NULL) {
  # nocov
  new_github_error(
    # nocov
    "Can't find GitHub user {rem$username}.", # nocov
    call. = call. # nocov
  ) # nocov
}

# No such repo

new_github_norepo_error <- function(rem, obj, call. = NULL) {
  new_github_error(
    sprintf("Can't find GitHub repo %s/%s.", rem$username, rem$repo),
    call. = call.
  )
}
# Not an R package?

new_github_no_package_error <- function(rem, call. = NULL) {
  subdir <- rem$subdir %&z&% paste0(" in directory '", rem$subdir, "'")
  msg <- sprintf(
    "Can't find R package in GitHub repo %s/%s%s",
    rem$username,
    rem$repo,
    subdir
  )
  new_github_error(msg, call. = call.)
}

# Invalid GitHub PAT

new_github_badpat_error <- function(call. = NULL) {
  new_github_error(paste0(
    "Bad GitHub credentials, ",
    "make sure that your GitHub token is valid."
  ))
}

# DESCRIPTION does not parse

new_github_baddesc_error <- function(rem, call. = NULL) {
  subdir <- rem$subdir %&z&% paste0(", in directory `", rem$subdir, "`")
  msg <- sprintf(
    "Can't parse DESCRIPTION file in GitHub repo %s/%s%s",
    rem$username,
    rem$repo,
    subdir
  )
  new_github_error(msg, call. = call.)
}

# No such PR

new_github_nopr_error <- function(rem, obj, call. = NULL) {
  msg <- sprintf(
    "Can't find PR #%s in GitHub repo %s/%s",
    rem$pull,
    rem$username,
    rem$repo
  )
  new_github_error(msg, call. = call.)
}

# No releases
new_github_no_release_error <- function(rem, obj, call. = NULL) {
  msg <- sprintf(
    "Can't find any release in GitHub repo %s/%s.",
    rem$username,
    rem$repo
  )
  new_github_error(msg, call. = call.)
}

# No such branch/tag/ref

new_github_noref_error <- function(rem, call. = NULL) {
  ref <- rem$commitish %|z|% "HEAD"
  msg <- sprintf(
    "Can't find reference @%s in GitHub repo %s/%s.",
    ref,
    rem$username,
    rem$repo
  )
  new_github_error(msg, call. = call.)
}

# Rate limited

new_github_ratelimited_error <- function(response, obj, call. = NULL) {
  headers <- curl::parse_headers_list(response$headers)
  ghmsgs <- sub("\\.?$", ".", vcapply(obj$errors, "[[", "message"))
  msg <- paste0("GitHub error: ", paste0(ghmsgs, collapse = ", "))
  if ("x-ratelimit-reset" %in% names(headers)) {
    reset <- format(
      .POSIXct(headers$`x-ratelimit-reset`, tz = "UTC"),
      usetz = TRUE
    )
    msg <- paste0(msg, " Rate limit will reset at ", reset, ".")
  }
  new_github_error(msg, call. = call.)
}
