in R/R/sqlPackage.R [1383:1716]
sqlInstallPackagesExtLib <- function(connectionString,
pkgs,
skipMissing = FALSE, repos, verbose,
scope = "private", owner = '',
serverVersion = serverVersion,
languageName)
{
g_scriptFile <- local(g_scriptFile, install.env)
# check permissions
#
checkPermission <- function(connectionString, scope, owner, verbose)
{
sqlCheckPermission <- function(connectionString, scope, owner)
{
allowed <- FALSE
haveOwner <- (nchar(owner) > 0)
query <- ""
if (haveOwner)
{
query <- paste0("EXECUTE AS USER = '", owner , "';\n")
}
query <- paste0(query, "SELECT USER;")
if (haveOwner)
{
query <- paste0(query, "\nREVERT;")
}
if(!is.null(g_scriptFile))
{
cat(query, file=g_scriptFile, append=TRUE)
cat("\n", file=g_scriptFile, append=TRUE)
}
sqlResult <- execute(connectionString, query)
if (is.data.frame(sqlResult))
{
user <- sqlResult[1,1]
if (user == '')
{
allowed <- FALSE
}
else if (scope == "PRIVATE" && user == "dbo")
{
# block dbo call to install into PRIVATE library path which is not supported by create external library
#
allowed <- FALSE
}
else
{
allowed <- TRUE
}
}
else
{
# cannot execute as the database principal because the principal "x" does not exist
#
allowed <- FALSE
}
return (allowed)
}
if (verbose)
{
write(sprintf("%s Verifying permissions to install packages on SQL server...", pkgTime()), stdout())
}
if (scope == "PUBLIC")
{
if (is.character(owner) && nchar(owner) > 0)
{
stop(paste0("Invalid use of scope PUBLIC. Use scope 'PRIVATE' to install packages for owner '", owner ,"'\n"), call. = FALSE)
}
}
else if (scope == "PRIVATE")
{
# fail dbo calls to install to private scope as dbo can only install to public
#
scopeint <- parseScope(scope)
allowed <- sqlCheckPermission(connectionString, scope, owner)
if (!allowed)
{
stop(sprintf("Permission denied for installing packages on SQL server for current user: scope='%s', owner='%s'.", scope, owner), call. = FALSE)
}
}
}
attributePackages <- function(connectionString, packages, scopeint, owner, verbose, languageName)
{
packagesNames <- sapply(packages, function(pkg) {pkg$name},USE.NAMES = FALSE)
if (verbose)
{
write(sprintf("%s Attributing packages on SQL server (%s)...", pkgTime(), paste(packagesNames, collapse = ', ')), stdout())
}
result <- sqlMakeTopLevel(connectionString = connectionString,
packages = packagesNames,
owner = owner,
scope = as.integer(scopeint),
languageName = languageName)
if (result)
{
write(sprintf("Successfully attributed packages on SQL server (%s).",
paste(packagesNames, collapse = ', ')), stdout())
}
}
# check scope and permission to write to scoped folder
#
scope <- normalizeScope(scope)
scopeint <- parseScope(scope)
if(verbose)
{
write(sprintf("%s Starting package install on SQL server (%s)...", pkgTime(), connectionString), stdout())
}
else
{
write(sprintf("(package install may take a few minutes, set verbose=TRUE for progress report)"), stdout())
}
checkPermission(connectionString, scope, owner, verbose)
topMostPackageFlag <- getPackageTopMostAttributeFlag()
if (length(pkgs) > 0)
{
downloadDir <- tempfile("download")
dir.create(downloadDir)
on.exit(unlink(downloadDir, recursive = TRUE), add = TRUE)
packages <- list()
if (missing(repos) || length(repos) > 0)
{
#
# get the contrib URLs
# (when client R and server R have different versions
# use server R version to find matching packages in repos)
#
contribSource <- NULL
contribWinBinary <- NULL
getContribUrls <- function(serverIsWindows)
{
repos <- getOption("repos")
contribSource <- utils::contrib.url(repos = repos, type = "source")
contribWinBinary <- NULL
if (serverIsWindows)
contribWinBinary <-utils::contrib.url(repos = repos, type = "win.binary")
return (list(ContribSource = contribSource, ContribWinBinary = contribWinBinary))
}
if(missing(repos))
{
rversion <- getRversionContribFormat()
if(rversion == serverVersion$rversion)
{
contribs <- getContribUrls(serverVersion$serverIsWindows)
}
else
{
write(sprintf("R version installed on sql server (%s) is different from the R version on client (%s). Using sql server R version to find matching packages in repositories.",
serverVersion$rversion, rversion), stdout())
contribs <- sqlRemoteExecuteFun(connectionString, getContribUrls, serverVersion$serverIsWindows, languageName = languageName)
}
contribSource <- contribs$ContribSource
contribWinBinary <- contribs$ContribWinBinary
}
else
{
# caller specified repo
#
contribSource <- utils::contrib.url(repos = repos, type = "source")
if(serverVersion$serverIsWindows)
{
contribWinBinary <- utils::contrib.url(repos = repos, type = "win.binary")
}
}
# get the available package lists
#
sourcePackages <- utils::available.packages(contribSource, type = "source")
row.names(sourcePackages) <- NULL
binaryPackages <- if (serverVersion$serverIsWindows) utils::available.packages(contribWinBinary, type = "win.binary") else NULL
row.names(binaryPackages) <- NULL
pkgsUnison <- data.frame(rbind(sourcePackages, binaryPackages), stringsAsFactors = FALSE)
pkgsUnison <- pkgsUnison[!duplicated(pkgsUnison$Package),,drop=FALSE]
row.names(pkgsUnison) <- pkgsUnison$Package
# check for missing packages
#
missingPkgs <- pkgs[!(pkgs %in% pkgsUnison$Package) ]
if (length(missingPkgs) > 0)
{
stop(sprintf("Cannot find specified packages (%s) to install", paste(missingPkgs, collapse = ', ')), call. = FALSE)
}
# get all installed packages
#
installedPackages <- sql_installed.packages(connectionString,
fields = NULL,
scope = scope,
owner = owner,
scriptFile = g_scriptFile,
languageName = languageName)
installedPackages <- data.frame(installedPackages, row.names = NULL, stringsAsFactors = FALSE)
# get dependency closure of given packages
#
pkgsToDownload <- getDependentPackagesToInstall(pkgs = pkgs, availablePackages = pkgsUnison,
installedPackages = installedPackages,
skipMissing = skipMissing, verbose = verbose)
# prune dependencies for already installed packages
#
prunedPkgs <- prunePackagesToInstallExtLib(dependentPackages = pkgsToDownload,
topMostPackages = pkgs,
installedPackages = installedPackages, verbose = verbose)
pkgsToDownload <- prunedPkgs[[1]]
pkgsToAttribute <- prunedPkgs[[2]]
if (length(pkgsToDownload) < 1 && length(pkgsToAttribute) < 1)
{
write(sprintf("Packages (%s) are already installed.", paste(pkgs, collapse = ', ')), stdout())
return (invisible(NULL))
}
if (length(pkgsToDownload) > 0)
{
serverVersion <- checkVersion(connectionString, languageName)
if (serverVersion$serverIsWindows)
{
pkgType = "win.binary"
}
else
{
pkgType = "source"
}
# download all the packages in dependency closure
#
downloadPkgs <- downloadDependentPackages(pkgs = pkgsToDownload, destdir = downloadDir,
binaryPackages = binaryPackages, sourcePackages = sourcePackages,
serverVersion=serverVersion, verbose = verbose, pkgType = pkgType)
}
if (length(pkgsToDownload) > 0)
{
attributesVec<-apply(downloadPkgs, 1, function(x)
{
packageAttributes <- 0x0
if (x["Package"] %in% pkgs)
{
packageAttributes <- bitwOr(packageAttributes,topMostPackageFlag)
}
return (packageAttributes)
})
downloadPkgs <- cbind(downloadPkgs, Attribute = attributesVec)
sqlHelperInstallPackages(connectionString, downloadPkgs, owner, scope, verbose, languageName)
}
if (length(pkgsToAttribute) > 0)
{
for (packageIndex in 1:nrow(pkgsToAttribute))
{
packageDescriptor <- list()
packageDescriptor$name <- pkgsToAttribute[packageIndex,"Package"]
packageAttributes <- 0x0
if (packageDescriptor$name %in% pkgs)
{
packageAttributes <- bitwOr(packageAttributes,topMostPackageFlag)
}
packageDescriptor$attributes <- packageAttributes
packages[[length(packages) + 1]] <- packageDescriptor
}
attributePackages(connectionString, packages, scopeint, owner, verbose, languageName)
}
}
else
{
# caller set repos = NULL, packages are file paths
#
pkgs <- normalizePath(pkgs, mustWork = FALSE)
missingPkgs <- pkgs[!file.exists(pkgs)]
if (length(missingPkgs) > 0)
{
stop(sprintf("%s packages are missing.", paste0(missingPkgs, collapse = ", ")), call. = FALSE)
}
packages <- data.frame(matrix(nrow = 0, ncol = 3), stringsAsFactors = FALSE)
for( packageFile in pkgs)
{
packages <- rbind(packages, data.frame(
Package = unlist(lapply(strsplit(basename(packageFile), '\\.|_'), '[[', 1), use.names = F),
File = packageFile,
Attribute = topMostPackageFlag,
stringsAsFactors = FALSE))
}
sqlHelperInstallPackages(connectionString, packages, owner, scope, verbose, languageName)
}
}
}