R/backend-file.R

In gaborcsardi/keyring: Access the System Credential Store from R

b_file_keyrings <- new.env(parent = emptyenv())

#' Encrypted file keyring backend
#'
#' This is a simple keyring backend, that stores/uses secrets in encrypted
#' files.
#'
#' It supports multiple keyrings.
#'
#' See [backend] for the documentation of the individual methods.
#'
#' @family keyring backends
#' @export
#' @include backend-class.R
#' @examples
#' \dontrun{
#' kb <- backend_file$new()
#' }

backend_file <- R6Class(
  "backend_file",
  inherit = backend_keyrings,
  public = list(
    name = "file",
    initialize = function(keyring = NULL)
      b_file_init(self, private, keyring),

    get = function(service, username = NULL, keyring = NULL)
      b_file_get(self, private, service, username, keyring),
    get_raw = function(service, username = NULL, keyring = NULL)
      b_file_get_raw(self, private, service, username, keyring),
    set = function(service, username = NULL, keyring = NULL,
                   prompt = NULL)
      b_file_set(self, private, service, username, keyring, prompt),
    set_with_value = function(service, username = NULL, password = NULL,
      keyring = NULL)
      b_file_set_with_value(self, private, service, username, password,
                            keyring),

    delete = function(service, username = NULL, keyring = NULL)
      b_file_delete(self, private, service, username, keyring),
    list = function(service = NULL, keyring = NULL)
      b_file_list(self, private, service, keyring),

    keyring_create = function(keyring = NULL, password = NULL)
      b_file_keyring_create(self, private, keyring, password),
    keyring_delete = function(keyring = NULL)
      b_file_keyring_delete(self, private, keyring),

    keyring_lock = function(keyring = NULL)
      b_file_keyring_lock(self, private, keyring),
    keyring_unlock = function(keyring = NULL, password = NULL)
      b_file_keyring_unlock(self, private, keyring, password),
    keyring_is_locked = function(keyring = NULL)
      b_file_keyring_is_locked(self, private, keyring),
    keyring_list = function()
      b_file_keyring_list(self, private),

    keyring_default = function()
      b_file_keyring_default(self, private),
    keyring_set_default = function(keyring)
      b_file_keyring_set_default(self, private, keyring),

    docs = function() {
      modifyList(super$docs(), list(. = paste0(
        "Store secrets in encrypted files.\n",
        private$keyring)))
    }
  ),

  private = list(
    keyring = NULL,

    keyring_create_direct = function(keyring = NULL, password = NULL, prompt = NULL)
      b__file_keyring_create_direct(self, private, keyring, password, prompt),
    keyring_autocreate = function(keyring = NULL)
      b__file_keyring_autocreate(self, private, keyring),
    keyring_file = function(keyring = NULL)
      b__file_keyring_file(self, private, keyring),
    keyring_read_file = function(keyring = NULL)
      b__file_keyring_read_file(self, private, keyring),
    keyring_write_file = function(keyring = NULL, nonce = NULL, items = NULL,
      key = NULL)
      b__file_keyring_write_file(self, private, keyring, nonce, items, key),

    get_keyring_pass = function(keyring = NULL)
      b__file_get_keyring_pass(self, private, keyring),
    set_keyring_pass = function(key = NULL, keyring = NULL)
      b__file_set_keyring_pass(self, private, key, keyring),
    unset_keyring_pass = function(keyring = NULL)
      b__file_unset_keyring_pass(self, private, keyring),
    is_set_keyring_pass = function(keyring = NULL)
      b__file_is_set_keyring_pass(self, private, keyring),

    update_cache = function(keyring = NULL, nonce = NULL, check = NULL,
      items = NULL)
      b__file_update_cache(self, private, keyring, nonce, check, items),
    get_cache = function(keyring = NULL)
      b__file_get_cache(self, private, keyring)
  )
)

b_file_init <- function(self, private, keyring) {
  self$keyring_set_default(keyring %||% "system")
  invisible(self)
}

b_file_get <- function(self, private, service, username, keyring) {

  private$keyring_autocreate(keyring)

  username <- username %||% getOption("keyring_username")
  if (self$keyring_is_locked(keyring)) self$keyring_unlock(keyring)

  cached <- private$get_cache(keyring)
  all_items <- cached$items
  all_services <- vapply(all_items, `[[`, character(1L), "service_name")
  item_matches <- all_services %in% service

  if (!is.null(username)) {
    all_users <- vapply(all_items, function(x) x$user_name %||% NA_character_, character(1L))
    item_matches <- item_matches & all_users %in% username
  }

  if (sum(item_matches) < 1L) {
    b_file_error("cannot get secret",
                 "The specified item could not be found in the keychain.")
  }

  vapply(
    lapply(all_items[item_matches], `[[`, "secret"),
    b_file_secret_decrypt,
    character(1L),
    cached$nonce,
    private$get_keyring_pass(keyring)
  )
}

b_file_set <- function(self, private, service, username, keyring,
                       prompt) {

  username <- username %||% getOption("keyring_username")

  keyring <- keyring %||% private$keyring
  file <- private$keyring_file(keyring)
  ex <- file.exists(file)

  # We use a different prompt in this case, to give a heads up
  prompt <- prompt %||% if (!ex && interactive()) {
    paste0(
      "Note: the specified keyring does not exist, you'll have to ",
      "create it in the next step. Key password: "
    )
  } else {
    "Password: "
  }

  password <- get_pass(prompt)
  if (is.null(password)) stop("Aborted setting keyring key")

  private$keyring_autocreate()

  self$set_with_value(service, username, password, keyring)

  invisible(self)
}

b_file_set_with_value <- function(self, private, service, username,
                                  password, keyring) {

  private$keyring_autocreate(keyring)

  username <- username %||% getOption("keyring_username")
  if (self$keyring_is_locked(keyring)) self$keyring_unlock(keyring)

  keyring_file <- private$keyring_file(keyring)
  kr_env <- b_file_keyring_env(keyring_file)

  with_lock(keyring_file, {
    cached <- private$get_cache(keyring)
    all_items <- cached$items

    services <- vapply(all_items, `[[`, character(1L), "service_name")
    users <- vapply(all_items, function(x) x$user_name %||% NA_character_, character(1))
    existing <- if (!is.null(username)) {
      services %in% service & users %in% username
    } else {
      services %in% service & is.na(users)
    }
    if (length(existing)) all_items <- all_items[!existing]

    new_item <- list(
      service_name = service,
      user_name = username,
      secret = b_file_secret_encrypt(
        password,
        cached$nonce,
        private$get_keyring_pass(keyring)
      )
    )

    items <- c(all_items, list(new_item))
    private$keyring_write_file(keyring, items = items)
    kr_env$stamp <- file_stamp(keyring_file)
  })

  kr_env <- b_file_keyring_env(keyring_file)
  kr_env$items <- items

  invisible(self)
}

b_file_delete <- function(self, private, service, username, keyring) {

  username <- username %||% getOption("keyring_username")
  if (self$keyring_is_locked(keyring)) self$keyring_unlock(keyring)

  keyring_file <- private$keyring_file(keyring)
  kr_env <- b_file_keyring_env(keyring_file)

  with_lock(keyring_file, {
    cached <- private$get_cache(keyring)
    all_items <- cached$items

    services <- vapply(all_items, `[[`, character(1L), "service_name")
    users <- vapply(all_items, function(x) x$user_name %||% NA_character_, character(1))
    existing <- if (!is.null(username)) {
      services %in% service & users %in% username
    } else {
      services %in% service & is.na(users)
    }
    if (length(existing) == 0) return(invisible(self))

    ## Remove
    items <- all_items[!existing]

    private$keyring_write_file(keyring, items = items)
    kr_env$stamp <- file_stamp(keyring_file)
  })

  kr_env$items <- items

  invisible(self)
}

b_file_list <- function(self, private, service, keyring) {

  private$keyring_autocreate(keyring)

  cached <- private$get_cache(keyring)
  all_items <- cached$items

  res <- data.frame(
    service = vapply(all_items, `[[`, character(1L), "service_name"),
    username = vapply(all_items, function(x) x$user_name %||% NA_character_, character(1)),
    stringsAsFactors = FALSE
  )

  if (!is.null(service)) {
    res[res[["service"]] == service, ]
  } else {
    res
  }
}

b_file_keyring_create <- function(self, private, keyring, password) {
  private$keyring_create_direct(keyring, password)
}

b_file_keyring_delete <- function(self, private, keyring) {

  self$keyring_lock(keyring)

  kr_file <- private$keyring_file(keyring)

  unlink(kr_file, recursive = TRUE, force = TRUE)

  invisible(self)
}

b_file_keyring_lock <- function(self, private, keyring) {
  keyring <- keyring %||% private$keyring
  file <- private$keyring_file(keyring)
  if (!file.exists(file)) {
    stop("The '", keyring, "' keyring does not exists, create it first!")
  }
  private$unset_keyring_pass(keyring)
  invisible(self)
}

b_file_keyring_unlock <- function(self, private, keyring, password) {

  file <- private$keyring_file(keyring)

  if (!file.exists(file)) {
    stop("Keyring `", keyring, "` does not exist")
  }

  private$set_keyring_pass(password, keyring)

  if (self$keyring_is_locked(keyring)) {
    private$unset_keyring_pass(keyring)
    b_file_error(
      "cannot unlock keyring",
      "The supplied password does not work."
    )
  }

  invisible(self)
}

b_file_keyring_is_locked <- function(self, private, keyring) {

  private$keyring_autocreate(keyring)

  keyring <- keyring %||% private$keyring
  file_name <- private$keyring_file(keyring)

  if (!file.exists(file_name)) {
    stop("Keyring `", keyring, "` does not exist")
  }

  if (!file.exists(file_name) || !private$is_set_keyring_pass(keyring)) {
    TRUE
  } else {
    tryCatch({
        cached <- private$get_cache(keyring)
        b_file_secret_decrypt(
          cached$check,
          cached$nonce,
          private$get_keyring_pass(keyring)
        )
        FALSE
      },
      error = function(e) {
        if(conditionMessage(e) == "Failed to decrypt")
          TRUE
        else
          stop(e)
      }
    )
  }
}

b_file_keyring_list <- function(self, private) {
  kr_dir <- dirname(private$keyring_file(NULL))
  files <- dir(kr_dir, pattern = "\\.keyring$", full.names = TRUE)
  names <- sub("\\.keyring", "",  basename(files))
  num_secrets <- vapply(
    files, function(f) length(yaml::yaml.load_file(f)$items), integer(1))
  locked <- vapply(
    names, function(k) self$keyring_is_locked(keyring = k), logical(1))
  data.frame(
    keyring = unname(names),
    num_secrets = unname(num_secrets),
    locked = unname(locked),
    stringsAsFactors = FALSE
  )
}

b_file_keyring_default <- function(self, private) {
  private$keyring
}

b_file_keyring_set_default <- function(self, private, keyring) {
  private$keyring <- keyring
  invisible(self)
}

## --------------------------------------------------------------------
## Private

b__file_keyring_create_direct <- function(self, private, keyring, password, prompt) {

  check_for_libsodium()
  keyring <- keyring %||% private$keyring
  prompt <- prompt %||% "Keyring password: "
  file_name <- private$keyring_file(keyring)

  if (file.exists(file_name)) {
    confirmation(paste("are you sure you want to overwrite", file_name,
                       "(type `yes` if so)"), "yes")
  }

  password <- password %||% get_pass(prompt)
  if (is.null(password)) stop("Aborted creating keyring")

  ## File need to exist for $set_keyring_pass() ...
  dir.create(dirname(file_name), recursive = TRUE, showWarnings = FALSE)
  cat("", file = file_name)
  key <- private$set_keyring_pass(password, keyring)

  with_lock(file_name,
    private$keyring_write_file(
      keyring,
      nonce = sodium::random(24L),
      items = list(),
      key = key
    )
  )

  invisible(self)
}

b__file_keyring_file <- function(self, private, keyring) {
  keyring <- keyring %||% private$keyring
  keyring_dir <- getOption("keyring_file_dir",
                           rappdirs::user_config_dir("r-keyring"))
  file.path(keyring_dir, paste0(keyring, ".keyring"))
}

b__file_keyring_read_file <- function(self, private, keyring) {

  check_for_libsodium()
  keyring <- keyring %||% private$keyring
  file_name <- private$keyring_file(keyring)

  with_lock(file_name, {
    stamp <- file_stamp(keyring)
    yml <- yaml::yaml.load_file(file_name)
  })

  assert_that(
    is_list_with_names(yml, names = c("keyring_info", "items")),
    is_list_with_names(
      yml[["keyring_info"]],
      names = c("keyring_version", "nonce", "integrity_check")
    )
  )

  list(
    nonce = sodium::hex2bin(yml[["keyring_info"]][["nonce"]]),
    items = lapply(yml[["items"]], b__file_validate_item),
    check = yml[["keyring_info"]][["integrity_check"]],
    stamp = stamp
  )
}

b__file_keyring_write_file <- function(self, private, keyring, nonce, items,
  key) {

  check_for_libsodium()
  keyring <- keyring %||% private$keyring
  file_name <- private$keyring_file(keyring)
  nonce <- nonce %||% private$get_cache(keyring)$nonce

  with_lock(
    file_name,
    yaml::write_yaml(
      list(
        keyring_info = list(
          keyring_version = as.character(getNamespaceVersion(.packageName)),
          nonce = sodium::bin2hex(nonce),
          integrity_check = b_file_secret_encrypt(
            paste(sample(letters, 22L, replace = TRUE), collapse = ""),
            nonce,
            key %||% private$get_keyring_pass(keyring)
          )
        ),
        items = items %||% private$get_cache(keyring)$items
       ),
      file_name
    )
  )

  invisible(self)
}

b__file_get_keyring_pass <- function(self, private, keyring) {

  kr_env <- b_file_keyring_env(private$keyring_file(keyring))

  if (is.null(kr_env$key)) {
    key <- private$set_keyring_pass(keyring = keyring)
  } else {
    key <- kr_env$key
  }

  assert_that(is.raw(key), length(key) > 0L)

  key
}

b__file_unset_keyring_pass <- function(self, private, keyring) {

  kr_env <- b_file_keyring_env(private$keyring_file(keyring))

  kr_env$key <- NULL

  invisible(kr_env)
}

b__file_is_set_keyring_pass <- function(self, private, keyring) {
  !is.null(b_file_keyring_env(private$keyring_file(keyring))$key)
}


b__file_set_keyring_pass <- function(self, private, key, keyring) {

  check_for_libsodium()
  key <- key %||% get_pass("Keyring password: ")
  if (is.null(key)) stop("Aborted setting keyring password")
  assert_that(is_string(key))
  key <- sodium::hash(charToRaw(key))

  kr_env <- b_file_keyring_env(private$keyring_file(keyring))

  kr_env$key <- key
}

b__file_update_cache <- function(self, private, keyring, nonce, check, items) {

  kr_env <- b_file_keyring_env(private$keyring_file(keyring))

  kr <- private$keyring_read_file(keyring)

  nonce <- nonce %||% kr[["nonce"]]
  assert_that(is.raw(nonce), length(nonce) > 0L)
  kr_env$nonce <- nonce

  check <- check %||% kr[["check"]]
  assert_that(is.character(check), length(check) > 0L)
  kr_env$check <- check

  kr_env$items <- lapply(items %||% kr[["items"]], b__file_validate_item)

  kr_env$stamp <- kr$stamp

  kr_env
}

b__file_get_cache <- function(self, private, keyring) {

  keyring_file <- private$keyring_file(keyring)
  kr_env <- b_file_keyring_env(keyring_file)

  if (is.null(kr_env$nonce) || is.null(kr_env$stamp) || is.na(kr_env$stamp) ||
      file_stamp(keyring_file) != kr_env$stamp) {
    kr_env <- private$update_cache(keyring)
  }

  assert_that(is.raw(kr_env$nonce), length(kr_env$nonce) > 0L)
  assert_that(is.character(kr_env$check), length(kr_env$check) > 0L)

  list(
    nonce = kr_env$nonce,
    items = lapply(kr_env$items, b__file_validate_item),
    check = kr_env$check)
}


## --------------------------------------------------------------------
## helper functions

b_file_secret_encrypt <- function(secret, nonce, key) {

  check_for_libsodium()
  res <- sodium::data_encrypt(
    charToRaw(secret),
    key,
    nonce
  )

  b_file_split_string(sodium::bin2hex(res))
}

b_file_secret_decrypt <- function(secret, nonce, key) {

  check_for_libsodium()
  rawToChar(
    sodium::data_decrypt(
      sodium::hex2bin(b_file_merge_string(secret)),
      key,
      nonce
    )
  )
}

b_file_keyring_env <- function(file_name) {

  env_name <- normalizePath(file_name, mustWork = TRUE)

  kr_env <- b_file_keyrings[[env_name]]

  if (is.null(kr_env)) {
    kr_env <- b_file_keyrings[[env_name]] <- new.env(parent = emptyenv())
  }

  kr_env
}

b_file_error <- function(problem, reason = NULL) {

  if (is.null(reason)) {
    info <- problem
  } else {
    info <- paste0(problem, ": ", reason)
  }

  stop("keyring error (file-based keyring), ", info, call. = FALSE)
}

b__file_validate_item <- function(item) {

  assert_that(
    is_list_with_names(item, names = c("service_name", "user_name", "secret")),
    is_string(item[["service_name"]]),
    is_string_or_null(item[["user_name"]]),
    is_string_or_raw(item[["secret"]])
  )

  invisible(item)
}

b_file_split_string <- function(string, width = 78L) {

  assert_that(is_string(string))

  paste(
    lapply(
      seq.int(ceiling(nchar(string) / width)) - 1L,
      function(x) substr(string, x * width + 1L, x * width + width)
    ),
    collapse = "\n"
  )
}

b_file_merge_string <- function(string) {
  assert_that(is_string(string))
  paste(strsplit(string, "\n")[[1L]], collapse = "")
}

b__file_keyring_autocreate <- function(self, private, keyring) {
  keyring <- keyring %||% private$keyring
  file <- private$keyring_file(keyring)
  if (!file.exists(file)) {
    if (is_interactive()) {
      private$keyring_create_direct(
        keyring,
        password = NULL,
        prompt = paste0(
          "The '", keyring,
          "' keyring does not exist, enter a keyring password to create it: "
        )
      )
    } else {
      stop("The '", keyring, "' keyring does not exists, create it first!")
    }
  }
}

with_lock <- function(file, expr) {
  timeout <- getOption("keyring_file_lock_timeout", 1000)
  lockfile <- paste0(file, ".lck")
  l <- filelock::lock(lockfile, timeout = timeout)
  if (is.null(l)) stop("Cannot lock keyring file")
  on.exit(filelock::unlock(l), add = TRUE)
  expr
}

check_for_libsodium <- function() {
  if ("sodium" %in% loadedNamespaces()) return()

  tryCatch(
    find.package("sodium"),
    error = function(err) {
      stop(
        "The 'file' keyring backend needs the sodium package, ",
        "please install it"
      )
    }
  )

  tryCatch(
    loadNamespace("sodium"),
    error = function(err) {
      if (Sys.info()[["sysname"]] == "Linux") {
        stop(
          call. = FALSE,
          "Cannot load the sodium package, please make sure that its ",
          "system libraries are installed.\n",
          "On Debian and Ubuntu systems you probably need the ",
          "'libsodium23' package.\n",
          "On Fedora, CentOS, RedHat and other RPM systems you need the ",
          "libsodium package. \n",
          "Error: ", conditionMessage(err)
        )
      } else {
        stop(
          call. = FALSE,
          "Cannot load the sodium package, please make sure that its ",
          "system libraries are installed. \n",
          "Error: ", conditionMessage(err)
        )
      }
    }
  )
}