More cache info parsing. #129

NAMESPACE

@@ -8,6 +8,7 @@ S3method(c,config)
 S3method(cookies,handle)
 S3method(cookies,response)
 S3method(headers,response)
+S3method(print,cache_info)
 S3method(print,config)
 S3method(print,handle)
 S3method(print,oauth_app)

R/cache.R

@@ -1,24 +1,83 @@
 #' Compute caching information for a response.
 #'
-#' @param x A response
+#' @param r A response
 #' @export
 #' @examples
-#' r <- GET("https://www.google.com")
-#' cache_info(r)
+#' r1 <- GET("https://www.google.com")
+#' cache_info(r1)
 #'
-#' r <- GET("https://www.google.com/images/srpr/logo11w.png")
-#' cache_info(r)
-cache_info <- function(x) {
+#' r2 <- GET("https://www.google.com/images/srpr/logo11w.png")
+#' cache_info(r2)
+cache_info <- function(r) {
   stopifnot(is.response(r))
 
-  list(
+  # If parsing fails using -Inf; If missing use NA
+  expires <- parse_http_date(r$headers$expires, Inf) %||% NULL
+
+  # Parse cache control
+  control <- parse_cache_control(r$headers$`cache-control`)
+  max_age <- as.integer(control$`max-age`) %||% NA
+  if (any(c("no-store", "no-cache") %in% control)) {
+    override <- FALSE
+  } else if (any(c("public", "private") %in% control)) {
+    override <- TRUE
+  } else {
+    override <- NA
+  }
+
+  # Compute expiry
+  if (!is.null(max_age)) {
     # If date missing, use request date
-    date = parse_http_date(r$headers$date) %||% r$date,
-    # If parsing fails using -Inf; If missing use NA
-    expires = parse_http_date(r$headers$expires, -Inf) %||% NA,
-    `cache-control` = r$headers$`cache-control`,
-    etag = r$headers$etag %||% NA,
-    `last-modified` = r$headers$`last-modified` %||% NA
+    date <- parse_http_date(r$headers$date) %||% r$date
+    expires <- date + max_age
+  } else if (!is.null(r$headers$expires)) {
+    expires <- parse_http_date(r$headers$expires, -Inf)
+  } else {
+    expires <- NULL
+  }
+
+  structure(
+    list(
+      method = r$method,
+      url = r$url,
+      status = r$status_code,
+
+      override = override,
+      expires = expires,
+      etag = r$headers$etag %||% NULL,
+      modified = parse_http_date(r$headers$`last-modified`, NULL)
+    ),
+    class = "cache_info"
   )
+}
+
+is.cache_info <- function(x) inherits(x, "cache_info")
+
+
+#' @export
+print.cache_info <- function(x, ...) {
+  cat("<cache_info> ", x$method, " ", x$url, "\n", sep = "")
+  if (!is.null(x$expires)) {
+    cat("  Expires:       ", http_date(x$expires), sep = "")
+    if (x$expires < Sys.time()) cat(" <expired>")
+    cat("\n")
+  }
+  cat("  Last-Modified: ", http_date(x$modified), "\n", sep = "")
+  cat("  Etag:          ", x$etag, "\n", sep = "")
+  cat("  Force caching: ", x$override, "\n", sep = "")
+}
+
+parse_cache_control <- function(x) {
+  pieces <- strsplit(x, ",")[[1]]
+  pieces <- gsub("^\\s+|\\s+$", "", pieces)
+  pieces <- tolower(pieces)
+
+  is_value <- grepl("=", pieces)
+  flags <- pieces[!is_value]
+
+  keyvalues <- strsplit(pieces[is_value], "\\s*=\\s*")
+  keys <- c("flags", lapply(keyvalues, "[[", 1))
+  values <- c(flags, lapply(keyvalues, "[[", 2))
 
+  setNames(values, keys)
 }

R/date.R

@@ -43,7 +43,8 @@ parse_http_date <- function(x, failure = NA) {
 #' @export
 #' @rdname parse_http_date
 http_date <- function(x) {
-  stopifnot(!inherits(x, "POSIXt"))
+  if (is.null(x)) return(NULL)
+  stopifnot(inherits(x, "POSIXt"))
   c_time(strftime(x, "%a, %d %b %Y %H:%M:%S", tz = "GMT", usetz = TRUE))
 }
 

R/http--request.r

@@ -22,7 +22,7 @@ make_request <- function(method, handle, url, config = NULL, body = NULL,
   }
 
   # Perform request and capture output
-  req <- perform(handle, opts, body)
+  req <- perform(handle, method, opts, body)
 
   needs_refresh <- refresh && req$status == 401L &&
     !is.null(config$token) && config$token$can_refresh()

R/perform.R

@@ -1,6 +1,6 @@
 # Abstract over the differences in RCurl API depending on whether or not
 # you send a body.
-perform <- function(handle, opts, body) {
+perform <- function(handle, method, opts, body) {
   # Must always override headerfunction and writefunction
   # FIXME: throw error if these are set already
   headers <- character()
@@ -32,6 +32,7 @@ perform <- function(handle, opts, body) {
   content <- methods::as(buffer, "raw")
 
   response(
+    method = toupper(method),
     url = last_request(handle)$effective.url,
     handle = handle,
     status_code = last(headers)$status,

R/utils.r

@@ -1,5 +1,5 @@
 "%||%" <- function(a, b) {
-  if (!is.null(a)) a else b
+  if (length(a) > 0) a else b
 }
 
 timestamp <- function(x = Sys.time()) {

man/cache_info.Rd

@@ -3,19 +3,19 @@
 \alias{cache_info}
 \title{Compute caching information for a response.}
 \usage{
-cache_info(x)
+cache_info(r)
 }
 \arguments{
-\item{x}{A response}
+\item{r}{A response}
 }
 \description{
 Compute caching information for a response.
 }
 \examples{
-r <- GET("https://www.google.com")
-cache_info(r)
+r1 <- GET("https://www.google.com")
+cache_info(r1)
 
-r <- GET("https://www.google.com/images/srpr/logo11w.png")
-cache_info(r)
+r2 <- GET("https://www.google.com/images/srpr/logo11w.png")
+cache_info(r2)
 }