R/gmailr.R

Defines functions gm_body gm_body.gmail_message gm_body.gmail_draft gm_id gm_id.gmail_message gm_id.gmail_messages gm_id.gmail_drafts gm_id.gmail_threads gm_to gm_to.gmail_message gm_to.gmail_draft gm_from gm_from.gmail_message gm_from gm_cc gm_cc.gmail_message gm_cc.gmail_draft gm_bcc gm_bcc.gmail_message gm_bcc.gmail_draft gm_date gm_date.default gm_date.gmail_message gm_date.gmail_draft gm_subject gm_subject.gmail_message gm_subject.gmail_draft header_value print.gmail_message print.gmail_thread print.gmail_draft print.gmail_messages print.gmail_threads print.gmail_drafts gmailr_query gm_last_response gmailr_GET gmailr_DELETE gmailr_PATCH gmailr_POST gmailr_PUT

Documented in gm_bcc gm_body gm_cc gm_date gm_from gm_id gm_id.gmail_messages gm_last_response gm_subject gm_to

#' \pkg{gmailr} makes gmail access easy.
#'
#' `gmailr` provides an interface to the gmail api <https://developers.google.com/gmail/api/>
#' @docType package
#' @name gmailr
#' @import httr
#' @import base64enc
NULL

#' Pipe statements
#'
#' Like dplyr and ggvis gmailr also uses the pipe function, `\%>\%` to turn
#' function composition into a series of imperative statements.
#'
#' @importFrom magrittr %>%
#' @name %>%
#' @rdname pipe
#' @export
#' @param lhs,rhs A visualisation and a function to apply to it
#' @examples
#' # Instead of
#' gm_to(gm_mime(), 'someone@@somewhere.com')
#' # you can write
#' gm_mime() %>% gm_to('someone@@somewhere.com')
NULL

#' 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
#' @inheritParams gm_id
#' @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)), ...)
}

the$last_response <- list()

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

  the$last_response <- response
  if (status_code(response) >= 300) {
    cond <- structure(list(
        call = sys.call(-1),
        content = result,
        response = response,
        message = paste0("Gmail API error: ", status_code(response), "\n  ", result$error$message, "\n")),
        class = c("condition", "error", "gmailr_error"))
    stop(cond)
  }

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

#' Response from the last query
#'
#' @export
gm_last_response <- function() {
  the$last_response
}

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

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

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

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

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

Try the gmailr package in your browser

Any scripts or data that you put into this service are public.

gmailr documentation built on Aug. 23, 2019, 5:06 p.m.