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