#  File src/library/tools/R/update_packages.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2017 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

## Code in this file adapted by Gabriel Becker from
## code distributed as part of the switchr R package.
## The modifications in this file and copyright thereof are
## donated without restriction to the R project.
##
## Original code and the switchr R package are
## Copyright 2018 Genentech Inc. All Rights Reserved.
## Author: Gabriel Becker <gabembecker@gmail.com>
## Distributed under the Artistic 2.0 License
## (re-licensed here to GPL 2+)

## canonical field order, from calling available.packages
## on CRAN repository (same result for Bioconductor)
fieldorder = c("Package", "Version", "Priority", "Depends",
               "Imports", "LinkingTo", "Suggests", "Enhances",
               "License", "License_is_FOSS", "License_restricts_use",
               "OS_type", "Archs", "MD5sum", "NeedsCompilation",     
               "File", "Repository")         

update_PACKAGES <- function(dir = ".", fields = NULL,
                            type = c("source", "mac.binary", 
                                     "win.binary"),
                            verbose.level = as.integer(dryrun),
                            latestOnly = TRUE,
                            addFiles = FALSE,
                            rds_compress = "xz",
                            strict = TRUE,
                            dryrun = FALSE)
{
    if(!is.integer(verbose.level))
        verbose.level = as.integer(verbose.level)
    type <- match.arg(type)
    stopifnot(verbose.level >= 0L && verbose.level <= 2L)
    PKGSfile <- file.path(dir, "PACKAGES")
    ## whether we will call write_PACKAGES directly/immediately
    calldown <- FALSE
    retdat <- NULL
    if(type == "win.binary" && strict) {
        warning("PACKAGES files do not include MD5 sums in the win.binary case",
                ", so strict checking is impossible. Calling down to write_PACKAGES ",
                "directly.")
        calldown <- TRUE
    } else if (!file.exists(PKGSfile)) {
        ## no PACKAGES file to update
        warning("No existing PACKAGES file found at ", PKGSfile)
        calldown <- TRUE
    } else if (!all(dim(retdat <- as.data.frame(read.dcf(PKGSfile),
                                         stringsAsFactors = FALSE)) > 0L)) {
        ## retdat is populated in the if condition here.
        ## read without fields restriction, because reducing number
        ## of fields is ok, adding fields means we need reprocessing

        ##0 rows and/or 0 columns
        warning("Existing PACKAGES file contained no rows and/or no columns")
        calldown <- TRUE
    }
    okfields <- names(retdat)
    
    ## can't update PACKAGES file if existing entries don't have all
    ## the required fields
    if(!calldown && !is.null(fields) && !all(fields %in% okfields)) {
        warning("Specified fields no present in existing PACKAGES file: ",
                paste(setdiff(fields, okfields), collapse = " "))
        calldown <- TRUE
    }
    
    ## call straight down to write_PACKAGES if:
    ## 1. type is win.binary and strict is TRUE (no MD5 sums to check against,
    ##    only way to get full strictness is write_PACKAGES
    ## 2. no PACKAGES file already exists or it's empty
    ## 3. 1+ specified field not present in existing PACKAGES file
    if(calldown) {
        if(verbose.level > 0L)
            message("Unable to update existing PACKAGES file. Calling write_PACKAGES directly.")
        return(write_PACKAGES(dir = dir, fields = fields, type = type,
                              verbose = verbose.level == 2,
                              latestOnly = latestOnly,
                              addFiles = addFiles, rds_compress = rds_compress))
    }
    ## we know file exists by this point
    pmtime <- file.info(PKGSfile)$mtime
    if(verbose.level > 0L) {
        message("Updating existing repository [strict mode: ",
                if(strict) "ON" else "OFF",
                "]\nDetected PACKAGES file with ", nrow(retdat),
                " entries at ", PKGSfile)
    }
    
    if(!is.null(fields))
        retdat <- retdat[, fields]
    
    pkgfiles <- list.files(dir, pattern = .get_pkg_file_pattern(type),
                           full.names = TRUE)
    if(length(pkgfiles) == 0L)
        stop("unable to find any package tarballs in ", dir)
    
    if(is.null(retdat$File)) {
        tbmatches <- match(paste(retdat$Package,
                                 retdat$Version,
                                 sep = "_"),
                           ## above doesn't have the extensions
                           gsub(.get_pkg_file_pattern(type, ext.only = TRUE),
                                "",
                                basename(pkgfiles)))
        ## this gets NAs for entries that don't have tarballs
        ## taken care of via keeprows below.
        retdat$tarball <- pkgfiles[tbmatches]
    } else
        retdat$tarball <- retdat$File

    ## for accounting purposes, removed before final write
    retdat$IsNew = FALSE

    ## detect and remove entries whose files have been deleted
    ## file.exists(NA_character_) returns FALSE, so this
    ## is ok without an explicit NA check
    keeprows <- file.exists(retdat$tarball)
    if(verbose.level > 0L) {
        msg <- paste("Tarballs found for", sum(keeprows), " of ",
                     nrow(retdat), "existing PACKAGES entries.")
        message(msg)
    }
    retdat <- retdat[keeprows,]

    ## check for tarballs that are too new
    ## remove entries which might appear to match them
    ## because the new tarball takes precedence.
    tbmtimes <- file.info(retdat$tarball)$mtime
    toonew <- which(tbmtimes > pmtime)
    if(length(toonew) > 0L) {
        if(verbose.level > 0L){
            msg <- paste(length(toonew), " tarball(s) matching existing entries are ",
                         "newer than PACKAGES file and must be reprocessed.")
            message(msg)
        }
        retdat <- retdat[-toonew, ]
    }
    
    ## If in strict mode we confirm that the MD5 sums match for
    ## tarballs which match pre-existing PACKAGES entries.
    ##
    ## Otherwise we skip this check for speed, assuming that
    ## any tarball we find is the one used to create the entry.
    ##
    ## Note: skipping the check can lead to a 'bad' repo in rare
    ## cases, but the installation machinery would still protect
    ## against non-malicious cases of this by failing out when the
    ##
    ## Note: MD5 sum didn't match what PACKAGES said it should be.
    ## In the win.binary case the existing PACKAGES file has no MD5
    ## sums, but we caught that above, so if strict is TRUE, we know
    ## type != win.binary.
    if(strict && NROW(retdat) > 0L) {
        if(verbose.level > 0L) {
            msg <- paste("[strict mode] Checking if MD5sums match ",
                         "for existing tarballs")
            message(msg)
        }
        curMD5sums <- md5sum(normalizePath(retdat$tarball))
        ## There are no NAs in retdat$MD5sum here, as the only data in
        ## there now is from the existing PACKAGES file.
        notokinds <- which(retdat$MD5sum != curMD5sums)
        if(length(notokinds) > 0L) {
            msg <- paste0("Detected ", length(notokinds), " MD5sum mismatches",
                          " between existing PACKAGES file and tarballs")
            warning(msg)
        } else if(verbose.level > 0L) {
            message("All existing entry MD5sums match tarballs.") 
        }
        ## tarballs that don't already ahve an entry
        ## OR that mismatched their existing entry
        ## possibly needing to be added
        if(length(notokinds) > 0L) {
            retdat <- retdat[-notokinds,]
        }
    }
    
    newpkgfiles <- setdiff(normalizePath(pkgfiles),
                           normalizePath(retdat$tarball))
    
    ## If we're willing to assume the filenames are honest and
    ## accurate, we can skip non-newest package versions without
    ## ever untaring them and reading their DESCRIPTION files.
    ##
    ## this is not the default because it is technically speaking
    ## less safe than what write_PACKAGES(,latestOnly=TRUE) does
    ## which is always process everything then prune.
    if(!strict &&
       latestOnly &&
       length(newpkgfiles) > 0L) {
        ##strip extension, left with pkgname_version
        newpkgtmp <- gsub(.get_pkg_file_pattern(type, ext.only = TRUE),
                          "",
                          basename(newpkgfiles))
        newpkgspl <- strsplit(basename(newpkgtmp), "_")
        newpkgdf <- do.call(rbind.data.frame,
                            c(newpkgspl, stringsAsFactors = FALSE))
        ## We create a dummy new repository db with only
        ## Package and Version columns, then fill them
        ## out with NAs so we can hit .remove_stale_dups
        ## before ever reading in the DESCRIPTION files
        ##
        ## These dummy db rows will all be replaced by the
        ## real data later in the process before the
        ## new PACKAGES files are written.
        
        newpkgdf <- newpkgdf[,1:2]
        names(newpkgdf) <- c("Package", "Version")
        newpkgdf <- .filldfcols(newpkgdf, retdat)
        ## for accounting purposes, taken back off later
        newpkgdf$IsNew <- TRUE
        newpkgdf$tarball <- newpkgfiles
        retdat <- rbind(retdat, newpkgdf) 
        ## remove non-latest ones now to avoid the expensive stuff
        ## this is non-strict because it assumes the package name and
        ## version in the filename are accurate. Technically, not
        ## guaranteed.
        retdat <- .remove_stale_dups(retdat)
        newpkgfiles <- retdat$tarball[retdat$IsNew]
    }
    
    ## Do any packages/package versions need to be added?
    numnew <- length(newpkgfiles)
    if(numnew > 0L) {
        if(verbose.level > 0L) {
            message("Found ", numnew, " package versions to process.")
        }
        
        ## returns a list of character vectors suitable for construction
        ## into a read.dcf output-style character matrix
        newpkgdat <- .process_package_files_for_repository_db(newpkgfiles,
                                                              type,
                                                              fields,
                                                              verbose.level > 1)
        newpkgdat <- .process_repository_package_db_to_matrix(newpkgdat,
                                                              path = "", #unused here
                                                              addFiles,
                                                              addPaths = FALSE, 
                                                              latestOnly)
        
        newpkgdf <- as.data.frame(newpkgdat, stringsAsFactors = FALSE)
           
        if(!identical(names(newpkgdf), names(retdat))) {
            ## make sure we catch columns only present in one or
            ## the other in both directions.
            ##
            ## the order of columns that comes out of this is columns
            ## in retdat (ie the original PACKAGES) in the order
            ## they appear there, THEN fields unique to the new tarballs
            ## appended in the order they appear there.
            newpkgdf <- .filldfcols(newpkgdf, retdat)
            retdat <- .filldfcols(retdat, newpkgdf)
        }
        
        if(verbose.level > 0L) {
            msg <- paste("Processed", nrow(newpkgdf), "entries from ",
                         "package tarballs.")
            message(msg)
        }
        
        ## just for accounting purposes
        ## taken back off later
        
        newpkgdf$IsNew <- TRUE
        retdat <- rbind(retdat[!retdat$IsNew,],
                        newpkgdf)
        if(latestOnly) {
            retdat <- .remove_stale_dups(retdat)
        }
        if(verbose.level > 0L) {
            msg <- paste(sum(retdat$IsNew), "entries added or updated, ",
                         sum(!retdat$IsNew), " entries retained unchanged.")
            message(msg)
        }
        
    } else if (verbose.level > 0L) {
        message("No new packages or updated package versions detected")
    }
    
    if(verbose.level > 0L) {
        msg <- paste("Final updated PACKAGES db contains ",
                     nrow(retdat), " entries.")
        message(msg)
    }

    ## write_PACKAGES docs don't define an order of entries, but I
    ## think it should(?) be sort order of files it processes. We
    ## reorder our db to give the same order.
    retdat <- retdat[order(paste0(retdat$Package, retdat$Version)),]

    ## clean up temp columns (note this works even if they aren't
    ## there so we don't need to worry about ones that are only
    ## defined within if blocks
    retdat$IsNew <- NULL
    retdat$tarball <- NULL

    ## guarantee canonical field order, with non-canonical fields
    ## appearing after
    noncanonfs <- setdiff(names(retdat), fieldorder)
    canonfs <- fieldorder[fieldorder %in% names(retdat)]
    retdat <- retdat[,c(canonfs, noncanonfs)]

    
    if(dryrun) {
        if(verbose.level > 0L)
            message("[dryrun mode] Dryrun complete.")
    } else {
        if(verbose.level > 0L)
            message("Writing final updated PACKAGES files.")
        ## crucial that db is written as a matrix
        ## otherwise available.packages, etc will fail
        db <- as.matrix(retdat)
        np <- .write_repository_package_db(db, dir, rds_compress)
        if(verbose.level > 0L)
            message("update_PACKAGES complete.")
    }
}


## pad df with columns from srcdf that it is missing,
## populated with NAs of the type appropriate for the
## column in srcdf. Must work for 0 row df or 0 row srcdf
##
## final col order: names(srcdf) followed by
## any columns unique to df
.filldfcols <- function(df, srcdf) {
    srcnames <- names(srcdf)
    dfnames <- names(df)
    newcols <- setdiff(srcnames, dfnames)
    df[,newcols] <- srcdf[integer(), newcols]
    df <- df[,unique(c(srcnames, dfnames))]
    df
}