1# 2# SessionConnections.R 3# 4# Copyright (C) 2021 by RStudio, PBC 5# 6# Unless you have received this program directly from RStudio pursuant 7# to the terms of a commercial license agreement with RStudio, then 8# this program is licensed to you under the terms of version 3 of the 9# GNU Affero General Public License. This program is distributed WITHOUT 10# ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT, 11# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the 12# AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details. 13# 14# 15 16.rs.addFunction("validateParams", function(obj, params, type, optional = FALSE) { 17 for (param in params) { 18 value <- obj[[param]] 19 if (optional && is.null(value)) 20 next 21 if (!inherits(value, type) || length(value) != 1) 22 stop(param, " must be a single element of type '", type, "'", 23 call. = FALSE) 24 } 25}) 26 27.rs.addFunction("validateCharacterParams", function(params, optional = FALSE) { 28 .rs.validateParams(params, names(params), "character", optional) 29}) 30 31.rs.addFunction("validateConnection", function(connection) { 32 .rs.validateParams(connection, 33 c("type", "host", "displayName", "connectCode"), 34 "character") 35 .rs.validateParams(connection, "icon", "character", optional = TRUE) 36 .rs.validateParams(connection, 37 c("disconnect", "listObjects", "listColumns", "previewObject"), 38 "function") 39}) 40 41# create an environment which will host the known active connections 42assign(".rs.activeConnections", 43 value = new.env(parent = emptyenv()), 44 envir = .rs.toolsEnv()) 45 46# given a connection type and host, find a matching active connection name, or 47# NULL if no connection was found 48.rs.addFunction("findConnectionName", function(type, host) { 49 connections <- ls(.rs.activeConnections) 50 for (name in connections) { 51 connection <- get(name, envir = .rs.activeConnections) 52 if (identical(connection$type, type) && 53 identical(connection$host, host)) { 54 return(name) 55 } 56 } 57 # indicates no connection was found 58 NULL 59}) 60 61# given a connection type and host, find an active connection object, or NULL if 62# no connection was found 63.rs.addFunction("findActiveConnection", function(type, host) { 64 65 name <- .rs.findConnectionName(type, host) 66 if (is.null(name)) 67 return(NULL) 68 69 if (exists(name, envir = .rs.activeConnections)) 70 get(name, envir = .rs.activeConnections) 71 72}) 73 74.rs.addFunction("connectionObserver.traceback", function() 75{ 76 .rs.getVar("connectionObserver.lastTraceback") 77}) 78 79.rs.addFunction("connectionObserver.connectionError", function(error) { 80 81 # save the error and calls 82 .rs.setVar("connectionObserver.lastTraceback", sys.calls()) 83 84 # be quiet if requested 85 suppressed <- getOption("rstudio.connectionObserver.errorsSuppressed", default = FALSE) 86 if (suppressed) 87 return() 88 89 # try to figure out what the offending package is 90 package <- NULL 91 92 frames <- sys.frames() 93 for (frame in rev(frames)) { 94 95 parent <- parent.env(frame) 96 if (identical(parent, baseenv()) || identical(parent, .BaseNamespaceEnv)) 97 next 98 99 if (isNamespace(parent)) { 100 spec <- getNamespaceInfo(parent, "spec") 101 package <- spec[["name"]] 102 break 103 } 104 105 } 106 107 # make header 108 header <- if (is.null(package)) { 109 "An error occurred while updating the RStudio Connections pane:" 110 } else { 111 fmt <- "An error occurred while the '%s' package was updating the RStudio Connections pane:" 112 sprintf(fmt, package) 113 } 114 115 # make body 116 fmt <- "Error in %s: %s" 117 body <- sprintf(fmt, format(error$call), format(error$message)) 118 119 # make footer 120 footer <- "If necessary, these warnings can be squelched by setting `options(rstudio.connectionObserver.errorsSuppressed = TRUE)`." 121 122 # notify user as message 123 all <- paste(c(header, body, footer), collapse = "\n") 124 message(all) 125 126}) 127 128.rs.addFunction( 129 "connectionObserver.connectionOpened", 130 function(type, host, displayName, icon = NULL, 131 connectCode, disconnect, listObjectTypes, 132 listObjects, listColumns, previewObject, 133 connectionObject, actions = NULL) 134 { 135 tryCatch( 136 137 .rs.connectionObserver.connectionOpenedImpl( 138 type, host, displayName, icon, 139 connectCode, disconnect, listObjectTypes, 140 listObjects, listColumns, previewObject, 141 connectionObject, actions 142 ), 143 144 error = .rs.connectionObserver.connectionError 145 146 ) 147 } 148) 149 150.rs.addFunction( 151 "connectionObserver.connectionOpenedImpl", 152 function(type, host, displayName, icon = NULL, 153 connectCode, disconnect, listObjectTypes, 154 listObjects, listColumns, previewObject, 155 connectionObject, actions = NULL) 156 { 157 # execute the object types function once to get the list of known 158 # object types; this is presumed to be static over the lifetime of the 159 # connection 160 if (!inherits(listObjectTypes, "function")) { 161 stop("listObjectTypes must be a function returning a list of object types", 162 call. = FALSE) 163 } 164 165 # function to flatten the tree of object types for more convenient storage 166 promote <- function(name, l) { 167 168 if (length(l) == 0) 169 return(list()) 170 171 if (is.null(l$contains)) { 172 # plain data 173 return(list(list(name = name, 174 icon = l$icon, 175 contains = "data"))) 176 } 177 178 # subtypes 179 return(unlist(append(list(list(list( 180 name = name, 181 icon = l$icon, 182 contains = names(l$contains)))), 183 lapply(names(l$contains), function(name) { 184 promote(name, l$contains[[name]]) 185 })), recursive = FALSE)) 186 187 } 188 189 # apply tree flattener to provided object tree 190 objectTree <- listObjectTypes() 191 objectTypes <- lapply(names(objectTree), function(name) { 192 promote(name, objectTree[[name]]) 193 })[[1]] 194 195 # manufacture and validate object representing this connection 196 connection <- list( 197 type = type, # the type of the connection 198 host = host, # the host being connected to 199 displayName = displayName, # the name to display 200 icon = icon, # an icon representing the connection 201 connectCode = connectCode, # code to (re)establish connection 202 disconnect = disconnect, # function that disconnects 203 objectTypes = objectTypes, # list of object types known 204 listObjects = listObjects, # list objects (all or in container) 205 listColumns = listColumns, # list columns of a data object 206 previewObject = previewObject, # preview an object 207 actions = actions, # list of actions possible on conn 208 connectionObject = connectionObject # raw connection object 209 ) 210 class(connection) <- "rstudioConnection" 211 .rs.validateConnection(connection) 212 213 # generate an internal key for this connection in the local cache 214 uuid <- .Call("rs_generateShortUuid", PACKAGE = "(embedding)") 215 cacheKey <- paste(connection$type, connection$host, uuid, sep = "_") 216 assign(cacheKey, value = connection, envir = .rs.activeConnections) 217 218 # serialize and generate client events 219 invisible(.Call("rs_connectionOpened", connection, PACKAGE = "(embedding)")) 220 } 221) 222 223.rs.addFunction( 224 "connectionObserver.connectionClosed", 225 function(type, host, ...) 226 { 227 tryCatch( 228 .rs.connectionObserver.connectionClosedImpl(type, host, ...), 229 error = .rs.connectionObserver.connectionError 230 ) 231 } 232) 233 234.rs.addFunction( 235 "connectionObserver.connectionClosedImpl", 236 function(type, host, ...) 237 { 238 .rs.validateCharacterParams(list(type = type, host = host)) 239 240 # clean up reference in environment 241 name <- .rs.findConnectionName(type, host) 242 if (!is.null(name)) 243 rm(list = name, envir = .rs.activeConnections) 244 245 invisible(.Call("rs_connectionClosed", type, host, PACKAGE = "(embedding)")) 246 } 247) 248 249.rs.addFunction( 250 "connectionObserver.connectionUpdated", 251 function(type, host, hint, ...) 252 { 253 tryCatch( 254 .rs.connectionObserver.connectionUpdatedImpl(type, host, hint, ...), 255 error = .rs.connectionObserver.connectionError 256 ) 257 } 258) 259 260 261.rs.addFunction( 262 "connectionObserver.connectionUpdatedImpl", 263 function(type, host, hint, ...) 264 { 265 .rs.validateCharacterParams(list(type = type, host = host, hint = hint)) 266 invisible(.Call("rs_connectionUpdated", type, host, hint, PACKAGE = "(embedding)")) 267 } 268) 269 270 271options( 272 connectionObserver = list( 273 connectionOpened = .rs.connectionObserver.connectionOpened, 274 connectionClosed = .rs.connectionObserver.connectionClosed, 275 connectionUpdated = .rs.connectionObserver.connectionUpdated 276 ) 277) 278 279.rs.addFunction("getConnectionObjectName", function(finder, host) { 280 finderFunc <- eval(parse(text = finder)) 281 finderFunc(globalenv(), host) 282}) 283 284.rs.addFunction("getConnectionObject", function(type, host) { 285 name <- .rs.getConnectionObjectName(type, host) 286 get(name, envir = globalenv()) 287}) 288 289.rs.addFunction("connectionDisconnect", function(type, host) { 290 connection <- .rs.findActiveConnection(type, host) 291 if (!is.null(connection)) 292 connection$disconnect() 293}) 294 295.rs.addFunction("connectionListObjects", function(type, host, ...) { 296 297 connection <- .rs.findActiveConnection(type, host) 298 299 if (!is.null(connection)) 300 connection$listObjects(...) 301 else 302 character() 303}) 304 305.rs.addFunction("connectionListColumns", function(type, host, ...) { 306 307 connection <- .rs.findActiveConnection(type, host) 308 309 if (!is.null(connection)) 310 listColumnsCode <- connection$listColumns(...) 311 else 312 NULL 313}) 314 315.rs.addFunction("connectionPreviewObject", function(type, host, limit, ...) { 316 317 connection <- .rs.findActiveConnection(type, host) 318 319 if (!is.null(connection)) { 320 df <- connection$previewObject(limit, ...) 321 322 # use the last element of the specifier to caption the frame 323 args <- list(...) 324 .rs.viewDataFrame(df, args[[length(args)]], TRUE) 325 } 326 327 NULL 328}) 329 330.rs.addFunction("connectionExecuteAction", function(type, host, action) { 331 332 connection <- .rs.findActiveConnection(type, host) 333 334 if (!is.null(connection) && action %in% names(connection$actions)) { 335 connection$actions[[action]]$callback() 336 } 337 338 NULL 339}) 340 341.rs.addFunction("connectionFilesPath", function() { 342 snippetsPath <- getOption("connections-path", "/etc/rstudio/connections/") 343 344 if (!is.null(getOption("connections-path")) && !dir.exists(snippetsPath)) { 345 warning( 346 "Path '", snippetsPath, "' does not exist. ", 347 "Configure the connections-path option appropriately.") 348 } 349 350 snippetsPath 351}) 352 353.rs.addFunction("connectionOdbcInstallerPath", function() { 354 normalizePath( 355 file.path( 356 .Call("rs_connectionOdbcInstallPath"), 357 "odbc", 358 "installers"), 359 mustWork = FALSE 360 ) 361}) 362 363.rs.addFunction("connectionFiles", function(include, defaultPath) { 364 connectionFiles <- list() 365 366 if (!is.null(defaultPath)) { 367 connectionFiles <- list.files(defaultPath) 368 } 369 370 files <- lapply(connectionFiles, function(file) { 371 fullPath <- file.path(defaultPath, file) 372 }) 373 374 names(files) <- gsub(include, "", connectionFiles) 375 376 files <- files[grepl(include, files)] 377 sapply(files, normalizePath) 378}) 379 380.rs.addFunction("connectionHasInstaller", function(name) { 381 installerName <- paste(name, "dcf", sep = ".") 382 connectionFiles <- as.character(.rs.connectionFiles("\\.dcf$", .rs.connectionOdbcInstallerPath())) 383 384 any(basename(connectionFiles) == installerName) 385}) 386 387.rs.addFunction("connectionInstallerInfo", function(name) { 388 installerName <- paste(name, "dcf", sep = ".") 389 installerFile <- as.character(.rs.connectionFiles(installerName, .rs.connectionOdbcInstallerPath())) 390 391 fileContents <- read.dcf(installerFile) 392 list( 393 name = if ("Name" %in% colnames(fileContents)) fileContents[,"Name"][[1]] else NULL, 394 version = if ("Version" %in% colnames(fileContents)) fileContents[,"Version"][[1]] else NULL 395 ) 396}) 397 398.rs.addFunction("connectionReadSnippets", function() { 399 snippetsPaths <- .rs.connectionFiles("\\.R$", .rs.connectionFilesPath()) 400 401 snippets <- lapply(snippetsPaths, function(fullPath) { 402 paste(readLines(fullPath), collapse = "\n") 403 }) 404 405 lapply(names(snippets), function(snippetName) { 406 tryCatch({ 407 snippet <- snippets[[snippetName]] 408 409 list( 410 package = .rs.scalar(NULL), 411 version = .rs.scalar(NULL), 412 name = .rs.scalar(snippetName), 413 type = .rs.scalar("Snippet"), 414 snippet = .rs.scalar(snippet), 415 help = .rs.scalar(NULL), 416 iconData = .rs.scalar(.Call("rs_connectionIcon", snippetName)), 417 licensed = .rs.scalar(FALSE), 418 source = .rs.scalar("Snippet"), 419 hasInstaller = .rs.scalar(FALSE) 420 ) 421 }, error = function(e) { 422 warning(e$message) 423 NULL 424 }) 425 }) 426}) 427 428.rs.addFunction("connectionOdbcInstallPath", function() 429{ 430 normalizePath( 431 file.path( 432 .Call("rs_connectionOdbcInstallPath"), 433 "odbc", 434 "drivers"), 435 mustWork = FALSE 436 ) 437}) 438 439.rs.addFunction("connectionReadInstallers", function() { 440 if (!.rs.isDesktop()) return(list()) 441 442 installerPaths <- .rs.connectionFiles("\\.dcf$", .rs.connectionOdbcInstallerPath()) 443 444 installers <- lapply(installerPaths, function(fullPath) { 445 read.dcf(fullPath) 446 }) 447 448 valueOrDefault <- function(name, data, default) { 449 cols <- colnames(data) 450 ifelse(name %in% cols, data[,name], default) 451 } 452 453 valueOrEmpty <- function(name, data) { 454 cols <- colnames(data) 455 ifelse(name %in% cols, data[,name], "") 456 } 457 458 lapply(names(installers), function(installerName) { 459 tryCatch({ 460 installer <- installers[[installerName]] 461 cols <- colnames(installer) 462 463 warning <- gsub( 464 "\n", 465 " ", 466 valueOrDefault( 467 paste("Warning", .Platform$OS.type, sep = "."), 468 installer, 469 valueOrEmpty("Warning", installer) 470 ) 471 ) 472 473 list( 474 package = .rs.scalar(NULL), 475 version = .rs.scalar(NULL), 476 name = .rs.scalar(installerName), 477 type = .rs.scalar("Install"), 478 subtype = .rs.scalar("Odbc"), 479 help = .rs.scalar(NULL), 480 iconData = .rs.scalar(.Call("rs_connectionIcon", installerName)), 481 licensed = .rs.scalar("Licensed" %in% colnames(installer)), 482 source = .rs.scalar("Snippet"), 483 snippet = .rs.scalar(""), 484 # odbc installer dcf fields 485 odbcVersion = .rs.scalar(valueOrEmpty("Version", installer)), 486 odbcLicense = .rs.scalar(gsub("\n", " ", valueOrEmpty("License", installer))), 487 odbcDownload = .rs.scalar(installer[,"Download"]), 488 odbcFile = .rs.scalar(valueOrEmpty("File", installer)), 489 odbcLibrary = .rs.scalar(valueOrEmpty("Library", installer)), 490 odbcWarning = .rs.scalar(warning), 491 odbcInstallPath = .rs.scalar(.rs.connectionOdbcInstallPath()), 492 odbcMD5 = .rs.scalar(gsub("\n", " ", valueOrEmpty("MD5", installer))), 493 hasInstaller = .rs.scalar(TRUE) 494 ) 495 }, error = function(e) { 496 warning(e$message) 497 NULL 498 }) 499 }) 500}) 501 502.rs.addFunction("connectionSupportedPackages", function() { 503 list( 504 list( 505 name = "ODBC", 506 package = "odbc", 507 version = "1.1.1" 508 ), 509 list( 510 name = "Spark", 511 package = "sparklyr", 512 version = "0.5.6" 513 ) 514 ) 515}) 516 517.rs.addFunction("connectionReadWindowsRegistry", function() { 518 registryOdbcPath <- "SOFTWARE\\ODBC\\ODBCINST.INI\\" 519 520 registryEntries <- lapply(names(readRegistry(registryOdbcPath)), function(driver) { 521 driverPath <- readRegistry(paste(registryOdbcPath, driver, sep = ""))$Driver 522 list(name = driver, attribute = "Driver", value = driverPath) 523 }) 524 525 registryEntriesValue <- Filter(function(e) !is.null(e$value), registryEntries) 526 527 do.call(rbind, lapply(registryEntriesValue, function(e) data.frame(e, stringsAsFactors = FALSE))) 528}) 529 530.rs.addFunction("connectionReadOdbcEntry", function(drivers, uniqueDriverNames, driver) { 531 tryCatch({ 532 currentDriver <- drivers[drivers$attribute == "Driver" & drivers$name == driver, ] 533 driverInstaller <- drivers[drivers$attribute == "Installer" & drivers$name == driver, ] 534 driverId <- gsub(.rs.connectionOdbcRStudioDriver(), "", driver) 535 536 basePath <- sub(paste(tolower(driver), ".*$", sep = ""), "", currentDriver$value) 537 snippetsFile <- file.path( 538 basePath, 539 tolower(driver), 540 "snippets", 541 paste(tolower(driverId), ".R", sep = "") 542 ) 543 544 if (identical(file.exists(snippetsFile), TRUE)) { 545 snippet <- paste(readLines(snippetsFile), collapse = "\n") 546 } 547 else { 548 snippet <- paste( 549 "library(DBI)\n", 550 "con <- dbConnect(odbc::odbc(), .connection_string = \"", 551 "Driver={", driver, "};${1:Parameters}\", timeout = 10)", 552 sep = "") 553 } 554 555 licenseFile <- file.path(dirname(currentDriver$value), "license.lock") 556 557 iconData <- .Call("rs_connectionIcon", driverId) 558 if (nchar(iconData) == 0) 559 iconData <- .Call("rs_connectionIcon", "ODBC") 560 561 hasInstaller <- identical(driverInstaller$value, "RStudio") 562 warningMessage <- NULL 563 564 if (hasInstaller) { 565 installerVersion <- .rs.connectionInstallerInfo(driverId)$version 566 567 currentVersion <- drivers[drivers$attribute == "Version" & drivers$name == driver, ] 568 if (nrow(currentVersion) == 1) { 569 if (compareVersion(installerVersion, currentVersion$value) > 0) { 570 warningMessage <- "A new driver version is available, to upgrade, uninstall and then reinstall." 571 } 572 } 573 } 574 575 list( 576 package = .rs.scalar(NULL), 577 version = .rs.scalar(NULL), 578 name = .rs.scalar(driver), 579 type = .rs.scalar("Snippet"), 580 snippet = .rs.scalar(snippet), 581 help = .rs.scalar(NULL), 582 iconData = .rs.scalar(iconData), 583 licensed = .rs.scalar(identical(file.exists(licenseFile), TRUE)), 584 source = .rs.scalar("ODBC"), 585 hasInstaller = .rs.scalar(hasInstaller), 586 warning = .rs.scalar(warningMessage), 587 installer = .rs.scalar(driverInstaller$value) 588 ) 589 }, error = function(e) { 590 warning(e$message) 591 NULL 592 }) 593}) 594 595.rs.addFunction("connectionReadOdbc", function() { 596 if (.rs.isPackageInstalled("odbc")) { 597 drivers <- data.frame() 598 599 tryCatch({ 600 drivers <- get("odbcListDrivers", envir = asNamespace("odbc"))() 601 602 if (.Platform$OS.type == "windows") { 603 drivers <- rbind(drivers, .rs.connectionReadWindowsRegistry()) 604 } 605 }, error = function(e) warning(e$message)) 606 607 uniqueDriverNames <- unique(drivers$name) 608 609 lapply(uniqueDriverNames, function(driver) { 610 .rs.connectionReadOdbcEntry(drivers, uniqueDriverNames, driver) 611 }) 612 } 613}) 614 615.rs.addFunction("connectionReadPackages", function() { 616 rawConnections <- .rs.fromJSON(.Call("rs_availableConnections")) 617 618 pacakgeConnections <- lapply(rawConnections, function(con) { 619 tryCatch({ 620 ns <- asNamespace(con$package) 621 622 connectionType <- if (nchar(con$shinyapp) == 0) "Snippet" else "Shiny" 623 snippetFile <- file.path("rstudio", "connections", paste(con$name, ".R", sep = "")) 624 snippet <- "" 625 626 if (nchar(con$shinyapp) == 0) { 627 snippetPath <- system.file(snippetFile, package = con$package) 628 if (!file.exists(snippetPath)) { 629 warning( 630 "The file \"", con$name, ".R\" does not exist under \"rstudio/connections\" for ", 631 "package \"", con$package , "\".") 632 } 633 else { 634 snippet <- paste(readLines(snippetPath), collapse = "\n") 635 } 636 } 637 else { 638 if (!exists(con$shinyapp, envir = ns, mode="function")) { 639 warning( 640 "The function \"", con$shinyapp, "\" does not exist. ", 641 "Check the ShinyApp DCF field in the ", con$package, " package.") 642 } 643 } 644 645 iconData <- if (nchar(con$icon) > 0) { 646 iconPath <- system.file(con$icon, package = con$package) 647 if (file.exists(iconPath)) { 648 paste0("data:image/png;base64,", .rs.base64encodeFile(iconPath)); 649 } 650 } 651 else { 652 .Call("rs_connectionIcon", con$name) 653 } 654 655 list( 656 package = .rs.scalar(con$package), 657 version = .rs.scalar(NULL), 658 name = .rs.scalar(con$name), 659 type = .rs.scalar(connectionType), 660 newConnection = .rs.scalar(paste(con$package, "::", con$shinyapp, "()", sep = "")), 661 snippet = .rs.scalar(snippet), 662 help = .rs.scalar(con$help), 663 iconData = .rs.scalar(iconData), 664 licensed = .rs.scalar(FALSE), 665 source = .rs.scalar("Package"), 666 hasInstaller = .rs.scalar(FALSE) 667 ) 668 }, error = function(e) { 669 warning(e$message) 670 NULL 671 }) 672 }) 673 674 names(pacakgeConnections) <- NULL 675 pacakgeConnections 676}) 677 678.rs.addFunction("connectionReadDSN", function() { 679 if (.rs.isPackageInstalled("odbc")) { 680 dataSources <- data.frame() 681 682 tryCatch({ 683 if (exists("list_data_sources", envir = asNamespace("odbc"))) { 684 listSources <- get("list_data_sources", envir = asNamespace("odbc")) 685 } 686 else { 687 listSources <- get("odbcListDataSources", envir = asNamespace("odbc")) 688 } 689 dataSources <- listSources() 690 }, error = function(e) warning(e$message)) 691 692 lapply(dataSources$name, function(dataSourceName) { 693 tryCatch({ 694 695 dataSource <- dataSources[dataSources$name == dataSourceName, ] 696 697 snippet <- paste( 698 "library(DBI)\n", 699 "con <- dbConnect(odbc::odbc(), \"${1:Data Source Name=", 700 dataSource$name, 701 "}\", timeout = 10)", 702 sep = "") 703 704 iconData <- .Call("rs_connectionIcon", dataSource$name) 705 if (nchar(iconData) == 0) 706 iconData <- .Call("rs_connectionIcon", "ODBC") 707 708 list( 709 package = .rs.scalar(NULL), 710 version = .rs.scalar(NULL), 711 name = .rs.scalar(dataSource$name), 712 type = .rs.scalar("Snippet"), 713 snippet = .rs.scalar(snippet), 714 help = .rs.scalar(NULL), 715 iconData = .rs.scalar(iconData), 716 licensed = .rs.scalar(FALSE), 717 source = .rs.scalar("DSN"), 718 hasInstaller = .rs.scalar(FALSE) 719 ) 720 }, error = function(e) { 721 warning(e$message) 722 NULL 723 }) 724 }) 725 } 726}) 727 728.rs.addFunction("connectionReadPackageInstallers", function() { 729 730 supportedNotInstsalled <- Filter(function(e) { 731 !.rs.isPackageVersionInstalled(e$package, e$version) 732 }, .rs.connectionSupportedPackages()) 733 734 lapply(supportedNotInstsalled, function(supportedPackage) { 735 iconData <- .Call("rs_connectionIcon", supportedPackage$name) 736 list( 737 package = .rs.scalar(supportedPackage$package), 738 version = .rs.scalar(supportedPackage$version), 739 name = .rs.scalar(supportedPackage$name), 740 type = .rs.scalar("Install"), 741 subtype = .rs.scalar("Package"), 742 newConnection = .rs.scalar(NULL), 743 snippet = .rs.scalar(NULL), 744 help = .rs.scalar(NULL), 745 iconData = .rs.scalar(iconData), 746 licensed = .rs.scalar(FALSE), 747 hasInstaller = .rs.scalar(FALSE) 748 ) 749 }) 750}) 751 752.rs.addJsonRpcHandler("get_new_connection_context", function() { 753 connectionList <- c( 754 list(), 755 .rs.connectionReadSnippets(), # add snippets to connections list 756 .rs.connectionReadDSN(), # add ODBC DSNs to connections list 757 .rs.connectionReadPackages(), # add packages to connections list 758 .rs.connectionReadOdbc(), # add ODBC drivers to connections list 759 .rs.connectionReadInstallers(), # add installers to connections list 760 .rs.connectionReadPackageInstallers() # add package installers to connection list 761 ) 762 763 connectionList <- Filter(function(e) !is.null(e), connectionList) 764 765 # remove duplicate names, in order 766 connectionNames <- list() 767 for (i in seq_along(connectionList)) { 768 entryName <- connectionList[[i]]$name 769 if (!is.null(connectionNames[[entryName]])) { 770 existingDriver <- connectionNames[[entryName]] 771 withRStudioName <- paste(entryName, .rs.connectionOdbcRStudioDriver(), sep = "") 772 773 if (identical(as.character(connectionList[[i]]$type), "Install") && 774 !identical(as.character(existingDriver$installer), "RStudio") && 775 is.null(connectionNames[[withRStudioName]])) { 776 connectionList[[i]]$name <- entryName <- .rs.scalar(withRStudioName) 777 } 778 else { 779 connectionList[[i]]$remove <- TRUE 780 } 781 } 782 783 if (is.null(connectionNames[[entryName]])) { 784 connectionNames[[entryName]] <- connectionList[[i]] 785 } 786 } 787 788 connectionList <- Filter(function(e) !identical(e$remove, TRUE), connectionList) 789 790 context <- list( 791 connectionsList = unname(connectionList) 792 ) 793 794 context 795}) 796 797.rs.addJsonRpcHandler("get_new_odbc_connection_context", function(name, retries = 1) { 798 singleEntryFilter <- function(e) { 799 identical(as.character(e$name), name) 800 } 801 802 connectionContext <- Filter(singleEntryFilter, .rs.connectionReadOdbc()) 803 804 while (length(connectionContext) != 1 && (retries <- retries - 1) >= 0) 805 Sys.sleep(1) 806 807 if (length(connectionContext) != 1) 808 list( 809 error = .rs.scalar( 810 paste("The", name, "driver is not registered.") 811 ) 812 ) 813 else { 814 connectionContext[[1]] 815 } 816}) 817 818.rs.addFunction("embeddedViewer", function(url) 819{ 820 .Call("rs_embeddedViewer", url) 821}) 822 823.rs.addJsonRpcHandler("launch_embedded_shiny_connection_ui", function(package, name) 824{ 825 if (package == "sparklyr" && packageVersion("sparklyr") <= "0.5.4") { 826 return(.rs.error( 827 "sparklyr ", packageVersion("sparklyr"), " does not support this functionality. ", 828 "Please upgrade to sparklyr 0.5.5 or newer." 829 )) 830 } 831 832 connectionContext <- .rs.rpc.get_new_connection_context()$connectionsList 833 connectionInfo <- Filter( 834 function(e) 835 identical(as.character(e$package), as.character(package)) & 836 identical(as.character(e$name), as.character(name)), 837 connectionContext 838 ) 839 840 if (length(connectionInfo) != 1) { 841 return(.rs.error( 842 "Connection for package ", package, " and name ", name, " is not registered" 843 )) 844 } 845 846 connectionInfo <- connectionInfo[[1]] 847 848 consoleCommand <- paste( 849 "shiny::runGadget(", 850 connectionInfo$newConnection, 851 ", viewer = .rs.embeddedViewer)", 852 sep = "" 853 ) 854 855 .rs.api.sendToConsole(consoleCommand, echo = FALSE, execute = TRUE, focus = FALSE) 856 857 .rs.success() 858}) 859 860.rs.addJsonRpcHandler("connection_test", function(code) { 861 error <- "" 862 863 oldConnectionObserver <- getOption("connectionObserver") 864 on.exit(options(connectionObserver = oldConnectionObserver)) 865 866 disconnectCalls <- list() 867 868 options(connectionObserver = list( 869 connectionOpened = function(type, host, displayName, icon = NULL, 870 connectCode, disconnect, listObjectTypes, 871 listObjects, listColumns, previewObject, 872 connectionObject, actions = NULL) { 873 disconnectCalls <<- c(disconnectCalls, disconnect) 874 }, 875 connectionClosed = function(type, host, ...) { 876 877 }, 878 connectionUpdated = function(type, host, hint, ...) { 879 } 880 )) 881 882 .envir <- .rs.getActiveFrame() 883 tryCatch({ 884 eval(parse(text = code), envir = .envir) 885 }, error = function(e) { 886 error <<- e$message 887 }) 888 889 lapply(disconnectCalls, function(e) e()) 890 891 .rs.scalar(error) 892}) 893 894.rs.addJsonRpcHandler("connection_add_package", function(package) { 895 extensionPath <- system.file("rstudio/connections.dcf", package = package) 896 invisible(.Call("rs_connectionAddPackage", package, extensionPath)) 897}) 898 899.rs.addFunction("connectionInstallerCommand", function(driverName, installationPath) { 900 connectionContext <- Filter(function(e) { 901 identical( 902 as.character(e$name), 903 gsub(.rs.connectionOdbcRStudioDriver(), "", driverName) 904 ) 905 }, .rs.connectionReadInstallers())[[1]] 906 907 placeholder <- connectionContext$odbcFile 908 driverUrl <- connectionContext$odbcDownload 909 libraryPattern <- connectionContext$odbcLibrary 910 targetMD5 <- connectionContext$odbcMD5 911 driverVersion <- connectionContext$odbcVersion 912 913 if (any(grepl("'", c(driverName, driverUrl, placeholder, installationPath, libraryPattern, targetMD5, driverVersion)))) { 914 stop("Single quote can't be used in installer definitions.") 915 } 916 917 paste( 918 ".rs.odbcBundleInstall(", 919 "name = '", driverName, "', ", 920 "url = '", driverUrl, "', ", 921 "placeholder = '", placeholder, "', ", 922 "installPath = '", normalizePath(installationPath, winslash = "/"), "', ", 923 "libraryPattern = '", libraryPattern, "', ", 924 "md5 = '", targetMD5, "', ", 925 "version = '", driverVersion, "'", 926 ")", 927 sep = "" 928 ) 929}) 930 931.rs.addFunction("connectionUnregisterOdbcinstDriver", function(driverName) { 932 odbcinstPath <- .rs.odbcBundleOdbcinstPath() 933 odbcinstData <- .rs.odbcBundleReadIni(odbcinstPath) 934 935 if (driverName %in% names(odbcinstData)) { 936 odbcinstData[[driverName]] <- NULL 937 938 .rs.odbcBundleWriteIni(odbcinstPath, odbcinstData) 939 } 940}) 941 942.rs.addFunction("connectionUnregisterWindowsDriver", function(driverName) { 943 .rs.odbcBundleRegistryRemove( 944 list( 945 list( 946 path = file.path("SOFTWARE", "ODBC", "ODBCINST.INI", "ODBC Drivers", fsep = "\\"), 947 key = driverName 948 ), 949 list( 950 path = file.path("SOFTWARE", "ODBC", "ODBCINST.INI", driverName, fsep = "\\") 951 ) 952 ) 953 ) 954}) 955 956.rs.addJsonRpcHandler("uninstall_odbc_driver", function(driverName) { 957 tryCatch({ 958 defaultInstallPath <- file.path(.rs.connectionOdbcInstallPath(), tolower(driverName)) 959 defaultInstallExists <- dir.exists(defaultInstallPath) 960 961 # delete the driver 962 if (defaultInstallExists) { 963 unlink(defaultInstallPath, recursive = TRUE) 964 } 965 966 # unregister driver 967 if (identical(tolower(Sys.info()["sysname"][[1]]), "windows")) { 968 .rs.connectionUnregisterWindowsDriver(driverName) 969 } 970 else { 971 .rs.connectionUnregisterOdbcinstDriver(driverName) 972 } 973 974 # if driver was not installed in default location 975 if (!defaultInstallExists) { 976 list( 977 message = .rs.scalar( 978 paste( 979 "The", driverName, "driver was not found in the default installation path;", 980 "if appropriate, please manually remove this driver." 981 ) 982 ) 983 ) 984 } 985 else { 986 list( 987 ) 988 } 989 }, error = function(e) { 990 list( 991 error = .rs.scalar(e$message) 992 ) 993 }) 994}) 995 996.rs.addJsonRpcHandler("update_odbc_installers", function() { 997 installerUrl <- getOption("connections-installer") 998 connectionsWarning <- NULL 999 1000 if (!.rs.isDesktop()) return(list()) 1001 1002 # once per session, attempt to download driver updates 1003 if (!is.null(installerUrl) && nchar(installerUrl) > 0) { 1004 installerHostName <- gsub("https?://|/[^:].+$", "", installerUrl) 1005 1006 connectionsWarning <- tryCatch({ 1007 installersFile <- file.path(tempdir(), basename(installerUrl)) 1008 download.file(installerUrl, installersFile, quiet = TRUE) 1009 1010 untar(installersFile, exdir = .rs.connectionOdbcInstallerPath()) 1011 1012 NULL 1013 }, error = function(e) { 1014 paste( 1015 "Could not retrieve driver updates from ", 1016 installerHostName, 1017 sep = "" 1018 ) 1019 }) 1020 } 1021 1022 list( 1023 warning = connectionsWarning 1024 ) 1025}) 1026