R/gmailr.R

In gmailr: Access the 'Gmail' 'RESTful' API

#' Get the body text of a message or draft
#' @param x the object from which to retrieve the body
#' @param ... other parameters passed to methods
#' @export
#' @examples
#' \dontrun{
#' gm_body(my_message)
#' gm_body(my_draft)
#' }
gm_body <- function(x, ...) UseMethod("gm_body")

#' @export
gm_body.gmail_message <- function(
  x,
  type = "text/plain",
  collapse = FALSE,
  ...
) {
  is_multipart <- !is.null(x$payload$parts)

  if (is_multipart) {
    if (is.null(type)) {
      good_parts <- TRUE
    } else {
      good_parts <- vapply(
        x$payload$parts,
        FUN.VALUE = logical(1),
        function(part) {
          any(
            vapply(part$headers, FUN.VALUE = logical(1), function(header) {
              tolower(header$name) %==%
                "content-type" &&
                grepl(type, header$value, ignore.case = TRUE)
            })
          )
        }
      )
    }

    res <-
      lapply(
        x$payload$parts[good_parts],
        function(x) {
          base64url_decode_to_char(x$body$data)
        }
      )
  } else {
    # non_multipart
    res <- base64url_decode_to_char(x$payload$body$data)
  }

  if (collapse) {
    res <- paste0(collapse = "\n", res)
  }

  res
}

#' @export
gm_body.gmail_draft <- function(x, ...) {
  gm_body.gmail_message(x$message, ...)
}

#' Get the id of a gmailr object
#' @param x the object from which to retrieve the id
#' @param ... other parameters passed to methods
#' @export
#' @examples
#' \dontrun{
#' gm_id(my_message)
#' gm_id(my_draft)
#' }
gm_id <- function(x, ...) UseMethod("gm_id")

#' @export
gm_id.gmail_message <- function(x, ...) {
  x$id
}

#' @export
gm_id.gmail_thread <- gm_id.gmail_message

#' @export
gm_id.gmail_draft <- gm_id.gmail_message

#' @rdname gm_id
#' @export
#' @param what the type of id to return
gm_id.gmail_messages <- function(x, what = c("message_id", "thread_id"), ...) {
  what <- switch(match.arg(what), message_id = "id", thread_id = "threadId")
  unlist(lapply(x, function(page) {
    vapply(page$messages, "[[", character(1), what)
  }))
}

#' @export
gm_id.gmail_drafts <- function(
  x,
  what = c("draft_id", "message_id", "thread_id"),
  ...
) {
  what <- switch(
    match.arg(what),
    draft_id = return(
      unlist(lapply(x, function(page) {
        vapply(page$drafts, "[[", character(1), "id")
      }))
    ),
    message_id = "id",
    thread_id = "threadId"
  )
  unlist(lapply(x, function(page) {
    vapply(
      page$drafts,
      function(x) {
        x$message[[what]]
      },
      character(1)
    )
  }))
}

#' @export
gm_id.gmail_threads <- function(x, ...) {
  unlist(lapply(x, function(page) {
    vapply(page$threads, "[[", character(1), "id")
  }))
}

#' Methods to get values from message or drafts
#' @param x the object from which to get or set the field
#' @param ... other parameters passed to methods
#' @rdname accessors
#' @export
gm_to <- function(x, ...) UseMethod("gm_to")

#' @export
gm_to.gmail_message <- function(x, ...) {
  header_value(x, "To")
}

#' @export
gm_to.gmail_draft <- function(x, ...) {
  gm_to.gmail_message(x$message, ...)
}

#' @rdname accessors
#' @export
gm_from <- function(x, ...) UseMethod("gm_from")

#' @export
gm_from.gmail_message <- function(x, ...) {
  header_value(x, "From")
}

#' @export
gm_from.gmail_draft <- gm_from.gmail_message

#' @export
gm_from <- function(x, ...) UseMethod("gm_from")

#' @rdname accessors
#' @export
gm_cc <- function(x, ...) UseMethod("gm_cc")

#' @export
gm_cc.gmail_message <- function(x, ...) {
  header_value(x, "Cc")
}

#' @export
gm_cc.gmail_draft <- function(x, ...) {
  gm_from.gmail_message(x$message, ...)
}

#' @rdname accessors
#' @export
gm_bcc <- function(x, ...) UseMethod("gm_bcc")

#' @export
gm_bcc.gmail_message <- function(x, ...) {
  header_value(x, "Bcc")
}

#' @export
gm_bcc.gmail_draft <- function(x, ...) {
  gm_from.gmail_message(x$message, ...)
}

#' @rdname accessors
#' @export
gm_date <- function(x, ...) UseMethod("gm_date")

#' @export
gm_date.default <- function(x, ...) {
  base::date()
}

#' @export
gm_date.gmail_message <- function(x, ...) {
  header_value(x, "Date")
}

#' @export
gm_date.gmail_draft <- function(x, ...) {
  gm_date.gmail_message(x$message, ...)
}

#' @rdname accessors
#' @export
gm_subject <- function(x, ...) UseMethod("gm_subject")

#' @export
gm_subject.gmail_message <- function(x, ...) {
  header_value(x, "Subject")
}

#' @export
gm_subject.gmail_draft <- function(x, ...) {
  gm_subject.gmail_message(x$message, ...)
}

header_value <- function(x, name) {
  mark_utf8(
    Find(function(header) identical(header$name, name), x$payload$headers)$value
  )
}

#' @export
print.gmail_message <- function(x, ...) {
  to <- gm_to(x)
  from <- gm_from(x)
  date <- gm_date(x)
  subject <- gm_subject(x)
  id <- gm_id(x)
  body <- gm_body(x, collapse = TRUE)
  attached_files <- unlist(lapply(x$payload$parts, function(part) {
    if (!is.null(part$filename) && part$filename != "") {
      part$filename
    }
  }))

  cat(p(
    c(
      crayon::bold("Id: "),
      id,
      "\n",
      if (!is.null(to)) {
        c(crayon::bold("To: "), to, "\n")
      },
      if (!is.null(from)) c(crayon::bold("From: "), from, "\n"),
      if (!is.null(date)) c(crayon::bold("Date: "), date, "\n"),
      if (!is.null(subject)) c(crayon::bold("Subject: "), subject, "\n"),
      if (!is.null(body)) c(body),
      if (!is.null(attached_files)) {
        c(
          crayon::bold("Attachments: "),
          paste0("'", attached_files, "'", collapse = ", "),
          "\n"
        )
      }
    )
  ))
}

#' @export
print.gmail_thread <- function(x, ...) {
  id <- gm_id(x)
  cat(strwrap(p(crayon::bold("Thread Id: "), id, "\n")), "\n")
}

#' @export
print.gmail_draft <- function(x, ...) {
  id <- gm_id(x)
  cat(strwrap(p(crayon::bold("Draft Id: "), id, "\n")), "\n")
  print(x$message, ...)
}

#' @export
print.gmail_messages <- function(x, ...) {
  message_ids <- gm_id(x, "message_id")
  thread_ids <- gm_id(x, "thread_id")
  print(
    format(data.frame(message_id = message_ids, thread_id = thread_ids)),
    ...
  )
}

#' @export
print.gmail_threads <- function(x, ...) {
  thread_ids <- gm_id(x)
  snippets <- unlist(lapply(x, function(page) {
    vapply(page$threads, "[[", character(1), "snippet")
  }))
  print(format(data.frame(thread_id = thread_ids, snippet = snippets)), ...)
}

#' @export
print.gmail_drafts <- function(x, ...) {
  draft_ids <- gm_id(x, "draft_id")
  message_ids <- gm_id(x, "message_id")
  thread_ids <- gm_id(x, "thread_id")
  print(
    format(data.frame(
      draft_ids,
      message_id = message_ids,
      thread_id = thread_ids
    )),
    ...
  )
}

gmailr_query <- function(
  fun,
  location,
  user_id,
  class = NULL,
  ...,
  upload = FALSE,
  call = caller_env()
) {
  path_fun <- if (upload) gmail_upload_path else gmail_path
  response <- fun(path_fun(user_id, location), gm_token(), ...)

  result <- gargle::response_process(
    response,
    remember = TRUE,
    call = call,
    error_class = "gmailr_error"
  )

  if (!is.null(class) && !is.null(result)) {
    class(result) <- class
  }
  result
}

#' Response from the last query
#'
#' `r lifecycle::badge("deprecated")`
#'
#' @description
#' gmailr now uses [gargle::response_process()] to process responses, so
#' [gargle::gargle_last_response()] can and should be used for *post mortem*
#' analysis, instead of `gm_last_response()`. One benefit of this switch is that
#' auth tokens are redacted in the stored response.
#'
#' @keywords internal
#' @export
gm_last_response <- function() {
  lifecycle::deprecate_warn(
    "3.0.0",
    "gm_last_response()",
    "gargle::gargle_last_response()"
  )
  gargle::gargle_last_response()
}

gmailr_GET <- function(
  location,
  user_id,
  class = NULL,
  ...,
  call = caller_env()
) {
  gmailr_query(GET, location, user_id, class, ..., call = call)
}

gmailr_DELETE <- function(
  location,
  user_id,
  class = NULL,
  ...,
  call = caller_env()
) {
  gmailr_query(DELETE, location, user_id, class, ..., call = call)
}

gmailr_PATCH <- function(
  location,
  user_id,
  class = NULL,
  ...,
  call = caller_env()
) {
  gmailr_query(PATCH, location, user_id, class, ..., call = call)
}

gmailr_POST <- function(
  location,
  user_id,
  class = NULL,
  ...,
  call = caller_env()
) {
  gmailr_query(POST, location, user_id, class, ..., call = call)
}

gmailr_PUT <- function(
  location,
  user_id,
  class = NULL,
  ...,
  call = caller_env()
) {
  gmailr_query(PUT, location, user_id, class, ..., call = call)
}