#
# SessionConnections.R
#
# Copyright (C) 2022 by Posit Software, PBC
#
# Unless you have received this program directly from Posit Software pursuant
# to the terms of a commercial license agreement with Posit Software, then
# this program is licensed to you under the terms of version 3 of the
# GNU Affero General Public License. This program is distributed WITHOUT
# ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT,
# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the
# AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details.
#
#

.rs.addFunction("validateParams", function(obj, params, type, optional = FALSE) {
   for (param in params) {
      value <- obj[[param]]
      if (optional && is.null(value))
         next
      if (!inherits(value, type) || length(value) != 1)
         stop(param, " must be a single element of type '", type, "'", 
              call. = FALSE)
   }
})

.rs.addFunction("validateCharacterParams", function(params, optional = FALSE) {
   .rs.validateParams(params, names(params), "character", optional)
})

.rs.addFunction("validateConnection", function(connection) {
   .rs.validateParams(connection, 
       c("type", "host", "displayName", "connectCode"),
       "character")
   .rs.validateParams(connection, c("icon", "clusterId"), "character", optional = TRUE)
   .rs.validateParams(connection, 
       c("disconnect", "listObjects", "listColumns", "previewObject"),
       "function")
})

# create an environment which will host the known active connections
assign(".rs.activeConnections", 
       value = new.env(parent = emptyenv()), 
       envir = .rs.toolsEnv())

# given a connection type and host, find a matching active connection name, or
# NULL if no connection was found
.rs.addFunction("findConnectionName", function(type, host) {
   connections <- ls(.rs.activeConnections)
   for (name in connections) {
      connection <- get(name, envir = .rs.activeConnections)
      if (identical(connection$type, type) && 
          identical(connection$host, host)) {
         return(name)
      }
   }
   # indicates no connection was found
   NULL
})

# given a connection type and host, find an active connection object, or NULL if
# no connection was found
.rs.addFunction("findActiveConnection", function(type, host) {
   
   name <- .rs.findConnectionName(type, host)
   if (is.null(name))
      return(NULL)
   
   if (exists(name, envir = .rs.activeConnections))
      get(name, envir = .rs.activeConnections)
   
})

.rs.addFunction("connectionObserver.traceback", function()
{
   .rs.getVar("connectionObserver.lastTraceback")
})

.rs.addFunction("connectionObserver.connectionError", function(error) {
   
   # save the error and calls
   .rs.setVar("connectionObserver.lastTraceback", sys.calls())
   
   # be quiet if requested
   suppressed <- getOption("rstudio.connectionObserver.errorsSuppressed", default = FALSE)
   if (suppressed)
      return()
   
   # try to figure out what the offending package is
   package <- NULL
   
   frames <- sys.frames()
   for (frame in rev(frames)) {
      
      parent <- parent.env(frame)
      if (identical(parent, baseenv()) || identical(parent, .BaseNamespaceEnv))
         next
      
      if (isNamespace(parent)) {
         spec <- getNamespaceInfo(parent, "spec")
         package <- spec[["name"]]
         break
      }
      
   }
   
   # make header
   header <- if (is.null(package)) {
      "An error occurred while updating the RStudio Connections pane:"
   } else {
      fmt <- "An error occurred while the '%s' package was updating the RStudio Connections pane:"
      sprintf(fmt, package)
   } 
   
   # make body
   fmt <- "Error in %s: %s"
   body <- sprintf(fmt, format(error$call), format(error$message))
   
   # make footer
   footer <- "If necessary, these warnings can be squelched by setting `options(rstudio.connectionObserver.errorsSuppressed = TRUE)`."
   
   # notify user as message
   all <- paste(c(header, body, footer), collapse = "\n")
   message(all)
   
})

.rs.addFunction(
   "connectionObserver.connectionOpened",
   function(type, host, displayName, icon = NULL, 
            connectCode, disconnect, listObjectTypes,
            listObjects, listColumns, previewObject, 
            connectionObject, actions = NULL)
   {
      tryCatch(
         
         .rs.connectionObserver.connectionOpenedImpl(
            type, host, displayName, icon, 
            connectCode, disconnect, listObjectTypes,
            listObjects, listColumns, previewObject, 
            connectionObject, actions
         ),
         
         error = .rs.connectionObserver.connectionError
         
      )
   }
)

.rs.addFunction(
   "connectionObserver.connectionOpenedImpl",
   function(type, host, displayName, icon = NULL, 
            connectCode, disconnect, listObjectTypes,
            listObjects, listColumns, previewObject, 
            connectionObject, actions = NULL)
   {
      # execute the object types function once to get the list of known 
      # object types; this is presumed to be static over the lifetime of the
      # connection
      if (!inherits(listObjectTypes, "function")) {
         stop("listObjectTypes must be a function returning a list of object types", 
              call. = FALSE)
      }
      
      # function to flatten the tree of object types for more convenient storage
      promote <- function(name, l) {
         
         if (length(l) == 0)
            return(list())
         
         if (is.null(l$contains)) {
            # plain data
            return(list(list(name = name,
                             icon = l$icon,
                             contains = "data")))
         } 
         
         # subtypes
         return(unlist(append(list(list(list(
            name = name, 
            icon = l$icon, 
            contains = names(l$contains)))),
            lapply(names(l$contains), function(name) {
               promote(name, l$contains[[name]])
            })), recursive = FALSE))
         
      }
      
      # apply tree flattener to provided object tree
      objectTree <- listObjectTypes()
      objectTypes <- lapply(names(objectTree), function(name) {
         promote(name, objectTree[[name]])
      })[[1]]

      # extract the cluster id from the connectionObject, if it exists
      clusterId <- .rs.getConnectionClusterId(connectionObject)
      
      # manufacture and validate object representing this connection
      connection <- list(
         type             = type,            # the type of the connection
         host             = host,            # the host being connected to
         displayName      = displayName,     # the name to display 
         icon             = icon,            # an icon representing the connection
         connectCode      = connectCode,     # code to (re)establish connection
         disconnect       = disconnect,      # function that disconnects
         objectTypes      = objectTypes,     # list of object types known 
         listObjects      = listObjects,     # list objects (all or in container)
         listColumns      = listColumns,     # list columns of a data object
         previewObject    = previewObject,   # preview an object
         actions          = actions,         # list of actions possible on conn
         clusterId        = clusterId,       # the cluster id for this connection, or empty string
         connectionObject = connectionObject # raw connection object
      )
      class(connection) <- "rstudioConnection"
      .rs.validateConnection(connection)
      
      # generate an internal key for this connection in the local cache
      uuid <- .Call("rs_generateShortUuid", PACKAGE = "(embedding)")
      cacheKey <- paste(connection$type, connection$host, uuid, sep = "_")
      assign(cacheKey, value = connection, envir = .rs.activeConnections)
      
      # serialize and generate client events
      invisible(.Call("rs_connectionOpened", connection, PACKAGE = "(embedding)"))
   }
)

.rs.addFunction(
   "connectionObserver.connectionClosed",
   function(type, host, ...)
   {
      tryCatch(
         .rs.connectionObserver.connectionClosedImpl(type, host, ...),
         error = .rs.connectionObserver.connectionError
      )
   }
)

.rs.addFunction(
   "connectionObserver.connectionClosedImpl",
   function(type, host, ...)
   {
      .rs.validateCharacterParams(list(type = type, host = host))
      
      # clean up reference in environment
      name <- .rs.findConnectionName(type, host)
      if (!is.null(name))
         rm(list = name, envir = .rs.activeConnections)
      
      invisible(.Call("rs_connectionClosed", type, host, PACKAGE = "(embedding)"))
   }
)

.rs.addFunction(
   "connectionObserver.connectionUpdated",
   function(type, host, hint, ...)
   {
      tryCatch(
         .rs.connectionObserver.connectionUpdatedImpl(type, host, hint, ...),
         error = .rs.connectionObserver.connectionError
      )
   }
)


.rs.addFunction(
   "connectionObserver.connectionUpdatedImpl",
   function(type, host, hint, ...)
   {
      .rs.validateCharacterParams(list(type = type, host = host, hint = hint))
      invisible(.Call("rs_connectionUpdated", type, host, hint, PACKAGE = "(embedding)"))
   }
)


options(
   connectionObserver = list(
      connectionOpened  = .rs.connectionObserver.connectionOpened,
      connectionClosed  = .rs.connectionObserver.connectionClosed,
      connectionUpdated = .rs.connectionObserver.connectionUpdated
   )
)

.rs.addFunction("getConnectionObjectName", function(finder, host) {
   finderFunc <- eval(parse(text = finder))
   finderFunc(globalenv(), host)
})

.rs.addFunction("getConnectionObject", function(type, host) {
   name <- .rs.getConnectionObjectName(type, host)
   get(name, envir = globalenv())
})

# assumes the connectionObject is an S4 object, list or other object with a
# cluster_id attribute/named element
# NOTE: we may want to expand the connections contract to allow for a
# getConnectionClusterId function to be passed to the connectionOpened function
.rs.addFunction("getConnectionClusterId", function(connectionObject) {
   if (!is.null(connectionObject)) {
      maybeClusterId <- NULL

      if (isS4(connectionObject)) {
         maybeClusterId <- attributes(connectionObject)$cluster_id
      } else {
         # if we're unable to get the cluster id from the connectionObject,
         # then the connectionsObject is malformed or is an object type we
         # don't currently support, so we just return an empty string
         maybeClusterId <- tryCatch(
            connectionObject$cluster_id,
            error = function(e) ""
         )
      }

      if (length(maybeClusterId) == 1 && is.character(maybeClusterId))
         return(maybeClusterId)
   }
   return("")
})

.rs.addFunction("connectionDisconnect", function(type, host) {
   connection <- .rs.findActiveConnection(type, host)
   if (!is.null(connection))
      connection$disconnect()
})

.rs.addFunction("connectionListObjects", function(type, host, ...) {

   connection <- .rs.findActiveConnection(type, host)

   if (!is.null(connection)) 
      connection$listObjects(...)
   else
      character()
})

.rs.addFunction("connectionListColumns", function(type, host, ...) {

   connection <- .rs.findActiveConnection(type, host)

   if (!is.null(connection))
      listColumnsCode <- connection$listColumns(...)
   else
      NULL
})

.rs.addFunction("connectionPreviewObject", function(type, host, limit, ...) {

   connection <- .rs.findActiveConnection(type, host)

   if (!is.null(connection)) {
      df <- connection$previewObject(limit, ...)

      # use the last element of the specifier to caption the frame
      args <- list(...)
      .rs.viewDataFrame(df, args[[length(args)]], TRUE)
   }

   NULL
})

.rs.addFunction("connectionExecuteAction", function(type, host, action) {

   connection <- .rs.findActiveConnection(type, host)

   if (!is.null(connection) && action %in% names(connection$actions)) {
      connection$actions[[action]]$callback()
   }

   NULL
})

.rs.addFunction("connectionFilesPath", function() {
   snippetsPath <- getOption("connections-path", "/etc/rstudio/connections/")

   if (!is.null(getOption("connections-path")) && !dir.exists(snippetsPath)) {
      warning(
         "Path '", snippetsPath, "' does not exist. ",
         "Configure the connections-path option appropriately.")
   }

   snippetsPath
})

.rs.addFunction("connectionOdbcInstallerPath", function() {
   normalizePath(
      file.path(
         .Call("rs_connectionOdbcInstallPath"),
         "odbc",
         "installers"),
      mustWork = FALSE
   )
})

.rs.addFunction("connectionFiles", function(include, defaultPath) {
   connectionFiles <- list()
   
   if (!is.null(defaultPath)) {
      connectionFiles <- list.files(defaultPath)
   }

   files <- lapply(connectionFiles, function(file) {
      fullPath <- file.path(defaultPath, file)
   })

   names(files) <- gsub(include, "", connectionFiles)

   files <- files[grepl(include, files)]
   sapply(files, normalizePath)
})

.rs.addFunction("connectionHasInstaller", function(name) {
   installerName <- paste(name, "dcf", sep = ".")
   connectionFiles <- as.character(.rs.connectionFiles("\\.dcf$", .rs.connectionOdbcInstallerPath()))
   
   any(basename(connectionFiles) == installerName)
})

.rs.addFunction("connectionInstallerInfo", function(name) {
   installerName <- paste(name, "dcf", sep = ".")
   installerFile <- as.character(.rs.connectionFiles(installerName, .rs.connectionOdbcInstallerPath()))

   fileContents <- read.dcf(installerFile)
   list(
      name = if ("Name" %in% colnames(fileContents)) fileContents[,"Name"][[1]] else NULL,
      version = if ("Version" %in% colnames(fileContents)) fileContents[,"Version"][[1]] else NULL
   )
})

.rs.addFunction("connectionReadSnippets", function() {
   snippetsPaths <- .rs.connectionFiles("\\.R$", .rs.connectionFilesPath())

   snippets <- lapply(snippetsPaths, function(fullPath) {
      paste(readLines(fullPath), collapse = "\n")
   })

   lapply(names(snippets), function(snippetName) {
      tryCatch({
         snippet <- snippets[[snippetName]]

         list(
            package = .rs.scalar(NULL),
            version = .rs.scalar(NULL),
            name = .rs.scalar(snippetName),
            type = .rs.scalar("Snippet"),
            snippet = .rs.scalar(snippet),
            help = .rs.scalar(NULL),
            iconData = .rs.scalar(.Call("rs_connectionIcon", snippetName)),
            licensed = .rs.scalar(FALSE),
            source = .rs.scalar("Snippet"),
            hasInstaller = .rs.scalar(FALSE)
         )
      }, error = function(e) {
         warning(e$message)
         NULL
      })
   })
})

.rs.addFunction("connectionOdbcInstallPath", function()
{
   normalizePath(
      file.path(
         .Call("rs_connectionOdbcInstallPath"),
         "odbc",
         "drivers"),
      mustWork = FALSE
   )
})

.rs.addFunction("connectionReadInstallers", function() {
   if (!.rs.isDesktop()) return(list())
   
   installerPaths <- .rs.connectionFiles("\\.dcf$", .rs.connectionOdbcInstallerPath())

   installers <- lapply(installerPaths, function(fullPath) {
      read.dcf(fullPath)
   })

   valueOrDefault <- function(name, data, default) {
      cols <- colnames(data)
      ifelse(name %in% cols, data[,name], default)
   }

   valueOrEmpty <- function(name, data) {
      cols <- colnames(data)
      ifelse(name %in% cols, data[,name], "")
   }

   lapply(names(installers), function(installerName) {
      tryCatch({
         installer <- installers[[installerName]]
         cols <- colnames(installer)

         warning <- gsub(
            "\n",
            " ",
            valueOrDefault(
               paste("Warning", .Platform$OS.type, sep = "."),
               installer,
               valueOrEmpty("Warning", installer)
            )
         )

         list(
            package = .rs.scalar(NULL),
            version = .rs.scalar(NULL),
            name = .rs.scalar(installerName),
            type = .rs.scalar("Install"),
            subtype = .rs.scalar("Odbc"),
            help = .rs.scalar(NULL),
            iconData = .rs.scalar(.Call("rs_connectionIcon", installerName)),
            licensed = .rs.scalar("Licensed" %in% colnames(installer)),
            source = .rs.scalar("Snippet"),
            snippet = .rs.scalar(""),
            # odbc installer dcf fields
            odbcVersion = .rs.scalar(valueOrEmpty("Version", installer)),
            odbcLicense = .rs.scalar(gsub("\n", " ", valueOrEmpty("License", installer))),
            odbcDownload = .rs.scalar(installer[,"Download"]),
            odbcFile = .rs.scalar(valueOrEmpty("File", installer)),
            odbcLibrary = .rs.scalar(valueOrEmpty("Library", installer)),
            odbcWarning = .rs.scalar(warning),
            odbcInstallPath = .rs.scalar(.rs.connectionOdbcInstallPath()),
            odbcMD5 = .rs.scalar(gsub("\n", " ", valueOrEmpty("MD5", installer))),
            hasInstaller = .rs.scalar(TRUE)
         )
      }, error = function(e) {
         warning(e$message)
         NULL
      })
   })
})

.rs.addFunction("connectionSupportedPackages", function() {
   list(
      list(
         name = "ODBC",
         package = "odbc",
         version = "1.1.1"
      ),
      list(
         name = "Spark",
         package = "sparklyr",
         version = "0.5.6"
      )
   )
})

.rs.addFunction("connectionReadWindowsRegistry", function() {
   registryOdbcPath <- "SOFTWARE\\ODBC\\ODBCINST.INI\\"

   registryEntries <- lapply(names(readRegistry(registryOdbcPath)), function(driver) {
     driverPath <- readRegistry(paste(registryOdbcPath, driver, sep = ""))$Driver
     list(name = driver, attribute = "Driver", value = driverPath)
   })

   registryEntriesValue <- Filter(function(e) !is.null(e$value), registryEntries)

   do.call(rbind, lapply(registryEntriesValue, function(e) data.frame(e, stringsAsFactors = FALSE)))
})

.rs.addFunction("connectionReadOdbcEntry", function(drivers, driver) {
   tryCatch({
      currentDriver <- drivers[drivers$attribute == "Driver" & drivers$name == driver, ]$value
      driverInstaller <- drivers[drivers$attribute == "Installer" & drivers$name == driver, ]$value
      driverId <- .rs.connectionStripRStudioDriver(driver)

      # Instead of assuming the location of the snippets directory, we instead
      # walk up the directory tree to find the snippets directory
      prevDir <- NULL
      walkDir <- dirname(currentDriver)
      while (!identical(walkDir, prevDir)) {
         snippetsDir <- file.path(walkDir, "snippets")
         if (dir.exists(snippetsDir)) {
            break
         }
         prevDir <- walkDir
         walkDir <- dirname(walkDir)
      }

      snippetsFile <- file.path(snippetsDir, paste(tolower(driverId), ".R", sep = ""))

      if (identical(file.exists(snippetsFile), TRUE)) {
         snippet <- paste(readLines(snippetsFile), collapse = "\n")
      }
      else {
         snippet <- paste(
            "library(DBI)\n",
            "con <- dbConnect(odbc::odbc(), .connection_string = \"", 
            "Driver={", driver, "};${1:Parameters}\", timeout = 10)",
            sep = "")
      }

      licenseFile <- file.path(dirname(currentDriver), "license.lock")

      iconData <- .Call("rs_connectionIcon", driverId)
      if (nchar(iconData) == 0)
         iconData <- .Call("rs_connectionIcon", "ODBC")

      hasInstaller <- identical(driverInstaller, "RStudio")
      warningMessage <- NULL

      if (hasInstaller) {
         installerVersion <- .rs.connectionInstallerInfo(driverId)$version

         currentVersion <- drivers[drivers$attribute == "Version" & drivers$name == driver, ]
         if (nrow(currentVersion) == 1) {
            if (compareVersion(installerVersion, currentVersion$value) > 0) {
               warningMessage <- "A new driver version is available, to upgrade, uninstall and then reinstall."
            }
         }
      }

      list(
         package = .rs.scalar(NULL),
         version = .rs.scalar(NULL),
         name = .rs.scalar(driver),
         type = .rs.scalar("Snippet"),
         snippet = .rs.scalar(snippet),
         help = .rs.scalar(NULL),
         iconData = .rs.scalar(iconData),
         licensed = .rs.scalar(identical(file.exists(licenseFile), TRUE)),
         source = .rs.scalar("ODBC"),
         hasInstaller = .rs.scalar(hasInstaller),
         warning = .rs.scalar(warningMessage),
         installer = .rs.scalar(driverInstaller)
      )
   }, error = function(e) {
      warning(e$message)
      NULL
   })
})

.rs.addFunction("connectionReadOdbc", function() {
   if (.rs.isPackageInstalled("odbc")) {
      drivers <- data.frame()

      tryCatch({
         drivers <- get("odbcListDrivers", envir = asNamespace("odbc"))()
         
         if (.Platform$OS.type == "windows") {
            drivers <- rbind(drivers, .rs.connectionReadWindowsRegistry())
         }
      }, error = function(e) warning(e$message))

      uniqueDriverNames <- unique(drivers$name)

      lapply(uniqueDriverNames, function(driver) {
         .rs.connectionReadOdbcEntry(drivers, driver)
      })
   }
})

.rs.addFunction("connectionReadPackages", function() {
   rawConnections <- .rs.fromJSON(.Call("rs_availableConnections"))

   pacakgeConnections <- lapply(rawConnections, function(con) {
      tryCatch({
         ns <- asNamespace(con$package)

         connectionType <- if (nchar(con$shinyapp) == 0) "Snippet" else "Shiny"
         snippetFile <- file.path("rstudio", "connections", paste(con$name, ".R", sep = ""))
         snippet <- ""

         if (nchar(con$shinyapp) == 0) {
            snippetPath <- system.file(snippetFile, package = con$package)
            if (!file.exists(snippetPath)) {
               warning(
                  "The file \"", con$name, ".R\" does not exist under \"rstudio/connections\" for ",
                  "package \"", con$package , "\".")
            }
            else {
               snippet <- paste(readLines(snippetPath), collapse = "\n")
            }
         }
         else {
            if (!exists(con$shinyapp, envir = ns, mode="function")) {
               warning(
                  "The function \"", con$shinyapp, "\" does not exist. ",
                  "Check the ShinyApp DCF field in the ", con$package, " package.")
            }
         }

         iconData <- if (nchar(con$icon) > 0) {
            iconPath <- system.file(con$icon, package = con$package)
            if (file.exists(iconPath)) {
               paste0("data:image/png;base64,", .rs.base64encodeFile(iconPath));
            }
         }
         else {
            .Call("rs_connectionIcon", con$name)
         }

         list(
            package = .rs.scalar(con$package),
            version = .rs.scalar(NULL),
            name = .rs.scalar(con$name),
            type = .rs.scalar(connectionType),
            newConnection = .rs.scalar(paste(con$package, "::", con$shinyapp, "()", sep = "")),
            snippet = .rs.scalar(snippet),
            help = .rs.scalar(con$help),
            iconData = .rs.scalar(iconData),
            licensed = .rs.scalar(FALSE),
            source = .rs.scalar("Package"),
            hasInstaller = .rs.scalar(FALSE)
         )
      }, error = function(e) {
         warning(e$message)
         NULL
      })
   })

   names(pacakgeConnections) <- NULL
   pacakgeConnections
})

.rs.addFunction("connectionReadDSN", function() {
   if (.rs.isPackageInstalled("odbc")) {
      dataSources <- data.frame()

      tryCatch({
         if (exists("list_data_sources", envir = asNamespace("odbc"))) {
            listSources <- get("list_data_sources", envir = asNamespace("odbc"))
         }
         else {
            listSources <- get("odbcListDataSources", envir = asNamespace("odbc"))
         }
         dataSources <- listSources()
      }, error = function(e) warning(e$message))

      lapply(dataSources$name, function(dataSourceName) {
         tryCatch({

            dataSource <- dataSources[dataSources$name == dataSourceName, ]

            snippet <- paste(
               "library(DBI)\n",
               "con <- dbConnect(odbc::odbc(), dsn=\"${1:Data Source Name=",
               dataSource$name,
               "}\", timeout = 10)",
               sep = "")

            iconData <- .Call("rs_connectionIcon", dataSource$name)
            if (nchar(iconData) == 0)
               iconData <- .Call("rs_connectionIcon", "ODBC")

            list(
               package = .rs.scalar(NULL),
               version = .rs.scalar(NULL),
               name = .rs.scalar(dataSource$name),
               type = .rs.scalar("Snippet"),
               snippet = .rs.scalar(snippet),
               help = .rs.scalar(NULL),
               iconData = .rs.scalar(iconData),
               licensed = .rs.scalar(FALSE),
               source = .rs.scalar("DSN"),
               hasInstaller = .rs.scalar(FALSE)
            )
         }, error = function(e) {
            warning(e$message)
            NULL
         })
      })
   }
})

.rs.addFunction("connectionReadPackageInstallers", function() {

   supportedNotInstsalled <- Filter(function(e) {
      !.rs.isPackageVersionInstalled(e$package, e$version)
   }, .rs.connectionSupportedPackages())

   lapply(supportedNotInstsalled, function(supportedPackage) {
      iconData <- .Call("rs_connectionIcon", supportedPackage$name)
      list(
         package = .rs.scalar(supportedPackage$package),
         version = .rs.scalar(supportedPackage$version),
         name = .rs.scalar(supportedPackage$name),
         type = .rs.scalar("Install"),
         subtype = .rs.scalar("Package"),
         newConnection = .rs.scalar(NULL),
         snippet = .rs.scalar(NULL),
         help = .rs.scalar(NULL),
         iconData = .rs.scalar(iconData),
         licensed = .rs.scalar(FALSE),
         hasInstaller = .rs.scalar(FALSE)
      )
   })
})

.rs.addFunction("connectionListFilter", function(connectionList) {
   # Function to filter and deduplicate entries in the connections list
   # The list may include multiple entries that have the same name,
   # which may be from the same source or from different sources altogether
   #
   # IMPORTANT: We reference and modify the connectionList entries in place,
   # even though it is less readable so that returned entries are modified
   
   connectionList <- Filter(function(e) !is.null(e), connectionList)

   # Installers that are managed by Pro Drivers or the RStudio IDE
   pro_driver_installers <- c("RStudio Pro Drivers", "Posit Pro Drivers")
   posit_installers <- c("RStudio", pro_driver_installers)
   # Helpers for connection list deduplication
   is_desktop_install <- function(entry) {
      identical(as.character(entry$installer), "RStudio") ||
      (
         # set by connectionReadInstallers
         identical(as.character(entry$type), "Install") &&
         identical(as.character(entry$subtype), "Odbc")
      )
   }
   is_pro_driver <- function(entry) {
      toString(entry$installer) %in% pro_driver_installers
   }

   # remove duplicate names, in order
   connectionNames <- list()
   for (i in seq_along(connectionList)) {
      entryName <- connectionList[[i]]$name
      if (!is.null(connectionNames[[entryName]])) {
         existingDriver <- connectionNames[[entryName]]
         withRStudioName <- paste(entryName, .rs.connectionOdbcRStudioDriver(), sep = "")

         if (is.null(connectionNames[[withRStudioName]]) &&
             !(toString(existingDriver$installer) %in% posit_installers) &&
             (is_desktop_install(connectionList[[i]]) || is_pro_driver(connectionList[[i]]))) {
            connectionList[[i]]$name <- entryName <- .rs.scalar(withRStudioName)
         }
         else {
            connectionList[[i]]$remove <- TRUE
         }
      }

      if (is.null(connectionNames[[entryName]])) {
         connectionNames[[entryName]] <- connectionList[[i]]
      }
   }
   
   connectionList <- Filter(function(e) !identical(e$remove, TRUE), connectionList)

   connectionList
})

.rs.addJsonRpcHandler("get_new_connection_context", function() {
   connectionList <- c(
      list(),
      .rs.connectionReadSnippets(),         # add snippets to connections list
      .rs.connectionReadDSN(),              # add ODBC DSNs to connections list
      .rs.connectionReadPackages(),         # add packages to connections list
      .rs.connectionReadOdbc(),             # add ODBC drivers to connections list
      .rs.connectionReadInstallers(),       # add installers to connections list
      .rs.connectionReadPackageInstallers() # add package installers to connection list
   )
   # Filter list to handle empty values and duplicate names
   connectionList <- .rs.connectionListFilter(connectionList)

   # Remove names before sending to the UI
   context <- list(
      connectionsList = unname(connectionList)
   )

   context
})

.rs.addJsonRpcHandler("get_new_odbc_connection_context", function(name, retries = 1) {
   name <- .rs.connectionStripRStudioDriver(name)
   singleEntryFilter <- function(e) {
      identical(as.character(e$name), name)
   }

   connectionContext <- Filter(singleEntryFilter, .rs.connectionReadOdbc())

   while (length(connectionContext) != 1 && (retries <- retries - 1) >= 0)
      Sys.sleep(1)

   if (length(connectionContext) != 1)
      list(
         error = .rs.scalar(
            paste("The", name, "driver is not registered.")
         )
      )
   else {
      connectionContext[[1]]
   }
})

.rs.addFunction("embeddedViewer", function(url)
{
   .Call("rs_embeddedViewer", url)
})

.rs.addJsonRpcHandler("launch_embedded_shiny_connection_ui", function(package, name)
{
   if (package == "sparklyr" && packageVersion("sparklyr") <= "0.5.4") {
      return(.rs.error(
         "sparklyr ", packageVersion("sparklyr"), " does not support this functionality. ",
         "Please upgrade to sparklyr 0.5.5 or newer."
      ))
   }

   connectionContext <- .rs.rpc.get_new_connection_context()$connectionsList
   connectionInfo <- Filter(
      function(e)
        identical(as.character(e$package), as.character(package)) &
        identical(as.character(e$name), as.character(name)),
      connectionContext
   )

   if (length(connectionInfo) != 1) {
      return(.rs.error(
         "Connection for package ", package, " and name ", name, " is not registered"
      ))
   }

   connectionInfo <- connectionInfo[[1]]

   consoleCommand <- paste(
      "shiny::runGadget(",
      connectionInfo$newConnection,
      ", viewer = .rs.embeddedViewer)",
      sep = ""
   )

   .rs.api.sendToConsole(consoleCommand, echo = FALSE, execute = TRUE, focus = FALSE)

   .rs.success()
})

.rs.addJsonRpcHandler("connection_test", function(code) {
   error <- ""

   oldConnectionObserver <- getOption("connectionObserver")
   on.exit(options(connectionObserver = oldConnectionObserver))

   disconnectCalls <- list()

   options(connectionObserver = list(
      connectionOpened = function(type, host, displayName, icon = NULL, 
                                  connectCode, disconnect, listObjectTypes,
                                  listObjects, listColumns, previewObject, 
                                  connectionObject, actions = NULL) {
         disconnectCalls <<- c(disconnectCalls, disconnect)
      },
      connectionClosed = function(type, host, ...) {

      },
      connectionUpdated = function(type, host, hint, ...) {
      }
   ))

   .envir <- .rs.getActiveFrame()
   tryCatch({
      eval(parse(text = code), envir = .envir)
   }, error = function(e) {
      error <<- e$message
   })

   lapply(disconnectCalls, function(e) e())

   .rs.scalar(error)
})

.rs.addJsonRpcHandler("connection_add_package", function(package) {
   extensionPath <- system.file("rstudio/connections.dcf", package = package)
   invisible(.Call("rs_connectionAddPackage", package, extensionPath))
})

.rs.addFunction("connectionInstallerCommand", function(driverName, installationPath) {
   connectionContext <- Filter(function(e) {
      identical(
         as.character(e$name),
         .rs.connectionStripRStudioDriver(driverName)
      )
   }, .rs.connectionReadInstallers())[[1]]

   placeholder <-  connectionContext$odbcFile
   driverUrl <- connectionContext$odbcDownload
   libraryPattern <- connectionContext$odbcLibrary
   targetMD5 <- connectionContext$odbcMD5
   driverVersion <- connectionContext$odbcVersion

   if (any(grepl("'", c(driverName, driverUrl, placeholder, installationPath, libraryPattern, targetMD5, driverVersion)))) {
      stop("Single quote can't be used in installer definitions.")
   }

   paste(
      ".rs.odbcBundleInstall(",
      "name = '", driverName, "', ",
      "url = '", driverUrl, "', ",
      "placeholder = '", placeholder, "', ",
      "installPath = '", normalizePath(installationPath, winslash = "/"), "', ",
      "libraryPattern = '", libraryPattern, "', ",
      "md5 = '", targetMD5, "', ",
      "version = '", driverVersion, "'",
      ")",
      sep = ""
   )
})

.rs.addFunction("connectionUnregisterOdbcinstDriver", function(driverName) {
   odbcinstPath <- .rs.odbcBundleOdbcinstPath()
   odbcinstData <- .rs.odbcBundleReadIni(odbcinstPath)

   if (driverName %in% names(odbcinstData)) {
      odbcinstData[[driverName]] <- NULL

      .rs.odbcBundleWriteIni(odbcinstPath, odbcinstData)
   }
})

.rs.addFunction("connectionUnregisterWindowsDriver", function(driverName) {
   .rs.odbcBundleRegistryRemove(
      list(
         list(
            path = file.path("SOFTWARE", "ODBC", "ODBCINST.INI", "ODBC Drivers", fsep = "\\"),
            key = driverName
         ),
         list(
            path = file.path("SOFTWARE", "ODBC", "ODBCINST.INI", driverName, fsep = "\\")
         )
      )
   )
})

.rs.addJsonRpcHandler("uninstall_odbc_driver", function(driverName) {
   tryCatch({
      driverName <- .rs.connectionStripRStudioDriver(driverName)
      defaultInstallPath <- file.path(.rs.connectionOdbcInstallPath(), tolower(driverName))
      defaultInstallExists <- dir.exists(defaultInstallPath)

      # delete the driver
      if (defaultInstallExists) {
         unlink(defaultInstallPath, recursive = TRUE)
      }

      # unregister driver
      if (identical(tolower(Sys.info()["sysname"][[1]]), "windows")) {
         .rs.connectionUnregisterWindowsDriver(driverName)
      }
      else {
         .rs.connectionUnregisterOdbcinstDriver(driverName)
      }

      # if driver was not installed in default location
      if (!defaultInstallExists) {
         list(
            message = .rs.scalar(
               paste(
                  "The", driverName, "driver was not found in the default installation path;",
                  "if appropriate, please manually remove this driver."
               )
            )
         )
      }
      else {
         list(
         )
      }
   }, error = function(e) {
      list(
         error = .rs.scalar(e$message)
      )
   })
})

.rs.addJsonRpcHandler("update_odbc_installers", function() {
   # pro drivers overlay
   installerUrl <- getOption("connections-installer", "https://cdn.rstudio.com/drivers/odbc-installer.tar.gz")
   connectionsWarning <- NULL

   if (!.rs.isDesktop()) return(list())

   # once per session, attempt to download driver updates
   if (!is.null(installerUrl) && nchar(installerUrl) > 0) {
      installerHostName <- gsub("https?://|/[^:].+$", "", installerUrl)

      connectionsWarning <- tryCatch({
         installersFile <- file.path(tempdir(), basename(installerUrl))
         download.file(installerUrl, installersFile, quiet = TRUE)

         untar(installersFile, exdir = .rs.connectionOdbcInstallerPath())

         NULL
      }, error = function(e) {
         paste(
            "Could not retrieve driver updates from ",
            installerHostName,
            sep = ""
         )
      })
   }

   list(
      warning = connectionsWarning
   )
})

###########
# PRO-ONLY
###########

.rs.addJsonRpcHandler("get_new_connection_context_databricks", function() {
   package <- "pysparklyr"
   # name is provided in inst/rstudio/connections.dcf in https://github.com/mlverse/pysparklyr
   name <- "Databricks Connect (DBR 13+)"

   connectionsList <- .rs.rpc.get_new_connection_context()$connectionsList

   filteredConnectionsList <- Filter(
      function(e)
        identical(as.character(e$package), as.character(package)) &
        identical(as.character(e$name), as.character(name)),
        connectionsList
   )

   if (length(filteredConnectionsList) != 1) {
      return(.rs.error(
         "Connection for package ", package, " and name ", name, " is not registered"
      ))
   }

   context <- list(
      connectionsList = unname(filteredConnectionsList)
   )

   context
})
