R/connect.R

In GlobalParametrics/taRpan_readonly: The read-only taRpan R package for accessing tarpan data systems

#' Tarpan Config
#'
#' Utility function that wraps the .tarpan config object
#'
#' @export
tarpan_config <- function() {
  .tarpan$config
}

#' tarpan2_connect
#'
#' @param dbname The database name to use in the connection
#' @param ... A list of parameters to pass to dbPool, which is essentially
#'   DBI::dbConnect
#'
#' @return A Pool object from the R6 Pool class.
#' @export
tarpan2_connect <- function(dbname = "postgres", ...) {
  args <- list(...)
  args$dbname <- dbname

  if (isTRUE(length(args)) > 0)
    .tarpan$tarpan2$pool <- do.call(make_tarpan2_connection, args)
  else if (all(c("host", "port", "user", "password") %in%
               names(tarpan_config())))
    .tarpan$tarpan2$pool <- make_tarpan2_connection(
      dbname = dbname,
      drv = PostgreSQL(),
      host = tarpan_config()$host,
      port = tarpan_config()$port,
      user = tarpan2_user(),
      password = tarpan2_password()
    )
  else
    stop("Must provide credentials or set them with set_tarpan2_credentials")

  invisible()
}

#' tarpan2_is_connected
#'
#' Check whether there is a connection to the provided database
#'
#' @param dbname character
#'
#' @return logical
#' @export
tarpan2_is_connected <- function(dbname = "postgres") {
  if (dbname == "postgres")
    if (inherits(.tarpan$tarpan2$pool, "Pool"))
      dbIsValid(.tarpan$tarpan2$pool)
    else
      FALSE
  else
    if (inherits(.tarpan$tarpan2$pools[[dbname]], "Pool"))
      dbIsValid(.tarpan$tarpan2$pools[[dbname]])
    else
      FALSE
}

#' make_tarpan2_connection
#'
#' Creates a connection to tarpan 2.0, but is essentially a wrapper for
#' \code{pool::dbPool}
#'
#' @param dbname The database named
#' @param drv The database driver (defaults to PostgreSQL)
#' @param user The user to connect with
#' @param password The user's password
#' @param host character
#' @param port integer/numeric
#' @param idleTimeout see \code{\link[pool]{poolCreate}}
#' @param validationInterval see \code{\link[pool]{poolCreate}}
#'
#' @export
make_tarpan2_connection <- function(dbname, drv = PostgreSQL(),
                                    user, password, host, port,
                                    idleTimeout = 600,
                                    validationInterval = 6000) {
  dbPool(
    dbname = dbname,
    drv = drv,
    user = user,
    password = password,
    host = host,
    port = port,
    idleTimeout = idleTimeout,
    validationInterval = validationInterval
  )
}

#' close_tarpan2_connection
#'
#' Close the standalone connection created with \code{make_tarpan2_connection}
#'
#' @param connection An object created by dbPool
#'
#' @export
close_tarpan2_connection <- function(connection) {
  tryCatch({
    poolClose(connection)
  }, error = function(e) {
    message("Error closing connection: ", e)
  })
}

#' tarpan2_disconnect
#'
#' Disconnect tarpan2 connection.
#'
#' @export
tarpan2_disconnect <- function() {
  disconnected <- FALSE

  if (inherits(.tarpan$tarpan2$pool, "Pool")) {
    tryCatch({
      close_tarpan2_connection(.tarpan$tarpan2$pool)
      .tarpan$tarpan2$pool <- NULL
    }, error = function(e) {
      message("Error closing connection: ", e)
    })

    disconnected <- TRUE
  }

  if (any(map_lgl(.tarpan$tarpan2$pools, function(x) inherits(x, "Pool")))) {
    for (pool in names(.tarpan$tarpan2$pools))
      if (inherits(.tarpan$tarpan2$pools[[pool]], "Pool"))
        tryCatch({
          close_tarpan2_connection(.tarpan$tarpan2$pools[[pool]])
          .tarpan$tarpan2$pools[[pool]] <- NULL
        }, error = function(e) {
          message("Error closing connection to database \"", pool, "\": ", e)
        })

    disconnected <- TRUE
  }

  if (disconnected)
    cat("Tarpan 2.0 disconnected\n")

  invisible()
}