Support cookies

Closes #2.

DESCRIPTION

@@ -45,4 +45,4 @@ Config/testthat/edition: 3
 Config/Needs/website: tidyverse/tidytemplate
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1.9000
+RoxygenNote: 7.2.3

NAMESPACE

@@ -10,8 +10,10 @@ S3method(print,webfakes_app_process)
 S3method(print,webfakes_regexp)
 S3method(print,webfakes_request)
 S3method(print,webfakes_response)
+export(http_time_stamp)
 export(httpbin_app)
 export(local_app_process)
+export(mw_cookie_parser)
 export(mw_etag)
 export(mw_json)
 export(mw_log)

NEWS.md

@@ -1,5 +1,10 @@
 # webfakes (development version)
 
+* New middleware `mw_cookie_parser()` to parse a `Cookie` header. Relatedly,
+  new `response$add_cookie()` method to add a cookie to a response.
+
+* New utility function `http_time_stamp()` to format a time stamp for HTTP.
+
 * The httpbin app now implements the `/cache` and `/cache/:value` endpoints.
 
 * The httpbin app now sends the `Date` header in the correct format.

R/httpbin.R

@@ -34,11 +34,6 @@ httpbin_app <- function(log = interactive()) {
     files
   }
 
-  time_stamp <- function(t = Sys.time()) {
-    t <- as.POSIXlt(t, tz = "UTC")
-    strftime(t, "%a, %d %b %Y %H:%M:%S GMT")
-  }
-
   app <- new_app()
 
   # Log requests by default
@@ -55,7 +50,7 @@ httpbin_app <- function(log = interactive()) {
 
   # Add date by default
   app$use("add date" = function(req, res) {
-    res$set_header("Date", time_stamp())
+    res$set_header("Date", http_time_stamp())
     "next"
   })
 
@@ -244,7 +239,7 @@ httpbin_app <- function(log = interactive()) {
   app$get("/cache", function(req, res) {
     if (is.null(req$get_header("If-Modified-Since")) &&
         is.null(req$get_header("If-None-Match"))) {
-      res$set_header("Last-Modified", time_stamp())
+      res$set_header("Last-Modified", http_time_stamp())
       # etag is added by default
       common_response(req, res)
     } else {

R/mw-cookie-parser.R

@@ -0,0 +1,34 @@
+
+#' Middleware to parse Cookies
+#'
+#' Adds the cookies as the `cookies` element of the request object.
+#'
+#' It ignores cookies in an invalid format. It ignores duplicate cookies:
+#' if two cookies have the same name, only the first one is included.
+#'
+#' @return Handler function.
+#'
+#' @family middleware
+#' @export
+
+mw_cookie_parser <- function() {
+  function(req, res) {
+    ch <- req$get_header("Cookie") %||% ""
+    req$cookies <- parse_cookies(ch)
+    "next"
+  }
+}
+
+parse_cookies <- function(x) {
+  parts <- strsplit(x, ";", fixed = TRUE, useBytes)[[1]]
+  dict <- structure(list(), names = character())
+  lapply(parts, function(ck) {
+    ck <- trimws(ck)
+    key <- sub("^([^=]+)=.*$", "\\1", ck)
+    if (key == ck) return()
+    if (!is.null(dict[[key]])) return()
+    value <- sub("^[^=]+=", "", ck)
+    dict[[key]] <<- value
+  })
+  dict
+}

R/response.R

@@ -57,6 +57,18 @@
 #'   character then it is set as is, otherwise it is assumed to be a file
 #'   extension, and the corresponding MIME type is set. If the headers have
 #'   been sent out already, then it throws a warning, and does nothing.
+#' * `add_cookie(name, value, options)`: Adds a cookie to the response.
+#'   `options` is a named list, and may contain:
+#'    * `domain`: Domain name for the cookie, not set by default.
+#'    * `expires`: Expiry date in GMT. It must be a POSIXct object, and
+#'       will be formatted correctly.
+#'    * 'http_only': if TRUE, then it sets the 'HttpOnly' attribute, so
+#'      Javasctipt cannot access the cookie.
+#'    * `max_age`: Maximum age, in number of seconds.
+#'    * `path`: Path for the cookie, defaults to "/".
+#'    * `same_site`: The 'SameSite' cookie attribute. Possible values are
+#'      "strict", "lax" and "none".
+#'    * `secure`: if TRUE, then it sets the 'Secure' attribute.
 #' * `write(data)`: writes (part of) the body of the response. It also
 #'   sends out the response headers, if they haven't been sent out before.
 #'
@@ -247,6 +259,29 @@ new_response <- function(app, req) {
       invisible(self)
     },
 
+    add_cookie = function(name, value, options = list()) {
+      if (!is_string(name)) {
+        stop("Cookie name must be a string.")
+      }
+      if (grepl("[=;]", name)) {
+        stop("Cookie value cannot contain ';' and '=' characters.")
+      }
+      if (!is_string(value)) {
+        stop("Cookie value must be a string.")
+      }
+      if (grepl("[=;]", value)) {
+        stop("Cookie value cannot contain ';' and '=' characters.")
+      }
+
+      ck <- paste0(
+        name, "=", value,
+        ";",
+        format_cookie_options(options)
+      )
+      self$add_header("Set-Cookie", ck)
+      invisible(self)
+    },
+
     write = function(data) {
       if (is.null(self$get_header("content-length"))) {
         warning("response$write() without a Content-Length header")
@@ -318,3 +353,61 @@ new_response <- function(app, req) {
 
   self
 }
+
+format_cookie_options <- function(options) {
+  options$path <- options$path %||% "/"
+
+  bad <- unique(setdiff(
+    names(options),
+    c("domain", "expires", "http_only", "max_age", "path", "same_site",
+      "secure")
+  ))
+  if (length(bad)) {
+    stop(
+      "Unknown or unsupported cookie attribute(s): ",
+      paste0("\"", bad, "\"", collapse = ", "),
+      "."
+    )
+  }
+
+  parts <- c(
+
+    if (!is.null(options$domain)) {
+      paste0("Domain=", options$domain)
+    },
+
+    if (!is.null(options$expires)) {
+      if (!inherits(options$expires, "POSIXct")) {
+        stop("The 'expires' cookie attribute must be a POSIXct object")
+      }
+      paste0("Expires=", http_time_stamp(options$expires))
+    },
+
+    if (isTRUE(options$http_only)) {
+      "HttpOnly"
+    },
+
+    if (!is.null(options$max_age)) {
+      paste0("Max-Age=", options$max_age)
+    },
+
+    paste0("Path=", options$path),
+
+    if (!is.null(options$same_site)) {
+      if (tolower(!options$same_site) %in% c("strict", "lax", "none")) {
+        stop(
+          "Invalid value for 'SameSite' cookie atrribute: ",
+          options$same_site,
+          ", must be \"strict\", \"lax\" or \"none\"."
+        )
+      }
+      paste0("SameSite=", capitalize(options$same_site))
+    },
+
+    if (isTRUE(options$secure)) {
+      "Secure"
+    }
+  )
+
+  paste(parts, collapse = "; ")
+}

R/utils.R

@@ -167,7 +167,14 @@ map_chr <- function(X, FUN, ...) {
   vapply(X, FUN, FUN.VALUE = character(1), ...)
 }
 
-time_stamp <- function(t = Sys.time()) {
+#' Format a time stamp for HTTP
+#'
+#' @param t Date-time value to format, defaults to the current date and
+#'   time. It must be a POSIXct object.
+#' @return Character vector, formatted date-time.
+#' @export
+
+http_time_stamp <- function(t = Sys.time()) {
   t <- as.POSIXlt(t, tz = "UTC")
   strftime(t, "%a, %d %b %Y %H:%M:%S GMT")
 }

_pkgdown.yml

@@ -2,7 +2,7 @@ template:
   package: tidytemplate
   bootstrap: 5
   assets: inst/examples/httpbin/assets
-  
+
   includes:
     in_header: |
       <script defer data-domain="webfakes.r-lib.org,all.tidyverse.org" src="https://plausible.io/js/plausible.js"></script>
@@ -48,6 +48,7 @@ reference:
 
 - title: Middleware to parse requests
   contents:
+  - mw_cookie_parser
   - mw_raw
   - mw_text
   - mw_json
@@ -75,5 +76,9 @@ reference:
   - oauth2_resource_app
   - oauth2_third_party_app
 
+- title: Misc Utilities
+  contents:
+  - http_time_stamp
+
 - title: internal
   contents: glossary

tests/testthat/test-httpbin.R

@@ -296,7 +296,7 @@ test_that("/cache", {
   curl::handle_setheaders(
     handle,
     "If-Modified-Since" =
-      time_stamp(Sys.time() - as.difftime(5, units = "mins"))
+      http_time_stamp(Sys.time() - as.difftime(5, units = "mins"))
   )
   resp <- curl::curl_fetch_memory(url, handle = handle)
   expect_equal(resp$status_code, 304L)