R/attach.r

In ropensci/sofa: Connector to 'CouchDB'

#' Work with attachments
#'
#' @name attachments
#' @template all
#' @template return
#' @param dbname (character) Database name. Required.
#' @param docid (character) Document ID. Required.
#' @param attachment (character) A file name. Required.
#' @param attname (character) Attachment name. Required.
#' @param type (character) one of raw (default) or text. required.
#' @details Methods:
#'
#' - `doc_attach_create` - create an attachment
#' - `doc_attach_info` - get info (headers) for an attachment
#' - `doc_attach_get` - get an attachment. this method does not attempt
#'  to read the object into R, but only gets the raw bytes or plain
#'  text. See examples for how to read some attachment types
#' - `doc_attach_delete` - delete and attachment
#'
#' @examples \dontrun{
#' user <- Sys.getenv("COUCHDB_TEST_USER")
#' pwd <- Sys.getenv("COUCHDB_TEST_PWD")
#' (x <- Cushion$new(user = user, pwd = pwd))
#'
#' if ("foodb" %in% db_list(x)) {
#'   invisible(db_delete(x, dbname = "foodb"))
#' }
#' db_create(x, dbname = "foodb")
#'
#' # create an attachment on an existing document
#' ## create a document first
#' doc <- '{"name":"stuff", "drink":"soda"}'
#' doc_create(x, dbname = "foodb", doc = doc, docid = "asoda")
#'
#' ## create a csv attachment
#' row.names(mtcars) <- NULL
#' file <- tempfile(fileext = ".csv")
#' write.csv(mtcars, file = file, row.names = FALSE)
#' doc_attach_create(x,
#'   dbname = "foodb", docid = "asoda",
#'   attachment = file, attname = "mtcarstable.csv"
#' )
#'
#' ## create a binary (png) attachment
#' file <- tempfile(fileext = ".png")
#' png(file)
#' plot(1:10)
#' dev.off()
#' doc_attach_create(x,
#'   dbname = "foodb", docid = "asoda",
#'   attachment = file, attname = "img.png"
#' )
#'
#' ## create a binary (pdf) attachment
#' file <- tempfile(fileext = ".pdf")
#' pdf(file)
#' plot(1:10)
#' dev.off()
#' doc_attach_create(x,
#'   dbname = "foodb", docid = "asoda",
#'   attachment = file, attname = "plot.pdf"
#' )
#'
#' # get info for an attachment (HEAD request)
#' doc_attach_info(x, "foodb", docid = "asoda", attname = "mtcarstable.csv")
#' doc_attach_info(x, "foodb", docid = "asoda", attname = "img.png")
#' doc_attach_info(x, "foodb", docid = "asoda", attname = "plot.pdf")
#'
#' # get an attachment (GET request)
#' res <- doc_attach_get(x, "foodb",
#'   docid = "asoda",
#'   attname = "mtcarstable.csv", type = "text"
#' )
#' read.csv(text = res)
#' doc_attach_get(x, "foodb", docid = "asoda", attname = "img.png")
#' doc_attach_get(x, "foodb", docid = "asoda", attname = "plot.pdf")
#' ## OR, don't specify an attachment and list the attachments
#' (attchms <- doc_attach_get(x, "foodb", docid = "asoda", type = "text"))
#' jsonlite::fromJSON(attchms)
#'
#' # delete an attachment
#' doc_attach_delete(x, "foodb", docid = "asoda", attname = "mtcarstable.csv")
#' doc_attach_delete(x, "foodb", docid = "asoda", attname = "img.png")
#' doc_attach_delete(x, "foodb", docid = "asoda", attname = "plot.pdf")
#' }

#' @export
#' @rdname attachments
doc_attach_create <- function(cushion, dbname, docid, attachment, attname,
                              as = "list", ...) {
  check_cushion(cushion)
  if (!file.exists(attachment)) stop("the file does not exist", call. = FALSE)
  revget <- db_revisions(cushion, dbname = dbname, docid = docid)[1]
  url <- file.path(cushion$make_url(), dbname, docid, attname)
  sofa_PUT_dac(url, as,
    body = crul::upload(attachment),
    rev = revget,
    headers = c(
      list(
        `Content-Type` = mime::guess_type(attachment)
      ),
      cushion$get_headers()
    ),
    auth = cushion$get_auth(), ...
  )
}

#' @export
#' @rdname attachments
doc_attach_info <- function(cushion, dbname, docid, attname, ...) {
  check_cushion(cushion)
  url <- file.path(cushion$make_url(), dbname, docid, attname)
  sofa_HEAD(url, cushion$get_headers(), cushion$get_auth(), ...)
}

#' @export
#' @rdname attachments
doc_attach_get <- function(
    cushion, dbname, docid, attname = NULL,
    type = "raw", ...) {
  check_cushion(cushion)
  if (is.null(attname)) {
    url <- file.path(cushion$make_url(), dbname, docid)
    query <- list(`_attachments` = "true")
  } else {
    url <- file.path(cushion$make_url(), dbname, docid, attname)
    query <- list()
  }
  revget <- db_revisions(cushion, dbname = dbname, docid = docid)[1]
  type <- match.arg(type, c("text", "raw"))
  cli <- crul::HttpClient$new(
    url = url,
    headers = sc(c(ct_json, cushion$get_headers(), list(`If-Match` = revget))),
    opts = sc(c(cushion$get_auth(), list(...)))
  )
  res <- cli$get(query = query)
  stop_status(res)
  if (type == "raw") res$content else res$parse("UTF-8")
}

#' @export
#' @rdname attachments
doc_attach_delete <- function(cushion, dbname, docid, attname, as = "list", ...) {
  check_cushion(cushion)
  revget <- db_revisions(cushion, dbname = dbname, docid = docid)[1]
  url <- file.path(cushion$make_url(), dbname, docid, attname)
  sofa_DELETE(
    url, as,
    sc(c(
      cushion$get_headers(),
      list(Accept = "application/json", `If-Match` = revget)
    )),
    cushion$get_auth(), ...
  )
}

sofa_PUT_dac <- function(url, as = "list", body, rev,
                         encode = "json", headers = NULL, auth = NULL, ...) {
  as <- match.arg(as, c("list", "json"))
  cli <- crul::HttpClient$new(
    url = url,
    headers = sc(c(headers, list(`If-Match` = rev))),
    opts = sc(c(auth, list(...)))
  )
  res <- cli$put(body = body, encode = encode)
  res$raise_for_status()
  tt <- res$parse("UTF-8")
  if (as == "json") tt else jsonlite::fromJSON(tt, FALSE)
}