R/cookie.R

In brochure: Multipage 'Shiny' Apps

#' Read the cookies sent with a request
#'
#' `get_cookies()` returns the raw `Cookie` header of the request the session
#' was opened with, and `parse_cookie_string()` turns that header into a named
#' vector.
#'
#' @param cookie_string The cookie string to parse, as `get_cookies()` returns
#' it.
#' @param session The `{shiny}` `session` object.
#'
#' @return For `get_cookies()`, the `Cookie` header as a single string, or
#' `NULL` when the request carried none. For `parse_cookie_string()`, a named
#' character vector of the cookies it holds, or `""` when given `NULL`. Index
#' it with single brackets: a visitor arriving without a cookie gives nothing
#' to index into, and `[[` errors where `[` returns `NA`.
#' @seealso [set_cookie()] to set one from a response handler, and
#' `vignette("cookies")` for carrying a session across pages.
#' @rdname cookies-server-side
#' @export
#'
#' @examples
#' parse_cookie_string("brochure_session=63422; brochure_cookie=3958")
parse_cookie_string <- function(cookie_string) {
  if (is.null(cookie_string)) {
    return("")
  }
  couples <- strsplit(cookie_string, ";")[[1]]
  res <- lapply(
    couples,
    function(x) {
      # Small hack to prevent splitting on the trailing =
      nms <- sub("=", "\\\\SPLITHERE\\\\", x)
      nms <- strsplit(nms, "\\\\SPLITHERE\\\\")[[1]]
      res <- gsub("^ +", "", nms[2])
      res <- gsub("[ ^]* +$", "", res)
      names(res) <- gsub("^ +", "", nms[1])
      names(res) <- gsub("[ ^]* +$", "", names(res))
      res
    }
  )
  unlist(res)
}

#' @rdname cookies-server-side
#' @export
get_cookies <- function(session = shiny::getDefaultReactiveDomain()) {
  session$request$HTTP_COOKIE
}


# RFC 6265. A cookie name is a token: printable US-ASCII (which already rules
# out CR, LF and every other control character) minus the separators. A value
# may hold separators, but not whitespace, double quotes, comma, semicolon or
# backslash. Letting any of those through lets a caller close the cookie and
# append attributes -- or, with CR/LF, a header of their own.
cookie_separators <- strsplit("()<>@,;:\\\"/[]?={}", "")[[1]]

cookie_token_ok <- function(x) {
  grepl("^[!-~]+$", x) &&
    !any(strsplit(x, "")[[1]] %in% cookie_separators)
}

cookie_value_ok <- function(x) {
  grepl("^[!-~]*$", x) &&
    !any(strsplit(x, "")[[1]] %in% c(",", ";", "\\", "\""))
}

# Max-Age is a number of seconds, and it is interpolated into the header like
# everything else, so a string gets the same scrutiny as a cookie value.
check_max_age <- function(max_age) {
  seconds <- suppressWarnings(as.integer(max_age))
  attempt::stop_if_not(
    length(max_age) == 1 && !is.na(seconds),
    isTRUE,
    "`max_age` must be a number of seconds."
  )
  seconds
}

check_cookie_part <- function(x, arg, ok) {
  attempt::stop_if_not(
    length(x) == 1 && ok(x),
    isTRUE,
    sprintf(
      "`%s` contains characters that are not allowed in a cookie.",
      arg
    )
  )
  x
}

#' Middleware to set cookies
#'
#' Please read https://developer.mozilla.org/en-US/docs/Web/HTTP/Reference/Headers/Set-Cookie
#' for more information.
#' Description of parameters is taken from this page.
#'
#' @param res An httpResponse object
#' @param name A cookie-name can be any US-ASCII characters,
#' except control characters, spaces, or tabs. It also must
#' not contain a separator character like the following:
#'  `( ) < > @ , ; : \ " / [ ] ? = { }`.
#' @param value A cookie-value can optionally be wrapped in
#' double quotes and include any US-ASCII characters excluding
#' control characters, Whitespace, double quotes, comma,
#' semicolon, and backslash.
#' @param expires The maximum lifetime of the cookie as
#' an HTTP-date timestamp. Please enter an ISO 8601 datetime format.
#' @param max_age Number of seconds until the cookie expires.
#' A zero or negative number will expire the cookie immediately.
#' If both Expires and Max-Age are set, Max-Age has precedence.
#' @param domain Host to which the cookie will be sent.
#' @param path A path that must exist in the requested URL,
#'  or the browser won't send the Cookie header. `remove_cookie()` only
#' deletes a cookie when it is given the same `path` and `domain` that
#' `set_cookie()` was given.
#' @param secure Cookie is only sent to the server
#' when a request is made with the https: scheme
#' (except on localhost), and therefore is more
#'  resistent to man-in-the-middle attacks.
#' @param http_only Forbids JavaScript from accessing the
#'  cookie, for example, through the Document.cookie property.
#' Defaults to `TRUE`.
#' @param same_site Controls whether a cookie is sent with
#' cross-origin requests, providing some protection against
#' cross-site request forgery attacks (CSRF). Defaults to `"Lax"`.
#'
#' @return the httpResponse, with a cookie header
#' @seealso [get_cookies()] to read them back, and `vignette("cookies")` for
#' carrying a session across pages.
#' @export
#' @rdname cookie-middleware
#'
#' @examples
#' set_cookie(
#'   shiny::httpResponse(),
#'   "this",
#'   12
#' )
set_cookie <- function(
  res,
  name,
  value,
  expires = NULL,
  max_age = NULL,
  domain = NULL,
  path = NULL,
  secure = NULL,
  http_only = TRUE,
  same_site = "Lax"
) {
  attempt::stop_if(
    name,
    missing,
    "`name` is required "
  )
  attempt::stop_if(
    value,
    missing,
    "`value` is required "
  )

  name <- check_cookie_part(as.character(name), "name", cookie_token_ok)
  value <- check_cookie_part(as.character(value), "value", cookie_value_ok)

  cook <- sprintf("%s=%s;", name, value)

  if (!is.null(expires)) {
    cook <- sprintf(
      "%s Expires = %s;",
      cook,
      http_date(as.POSIXlt(expires, tz = "GMT"))
    )
  }

  if (!is.null(max_age)) {
    cook <- sprintf(
      "%s Max-Age = %s;",
      cook,
      check_max_age(max_age)
    )
  }

  if (!is.null(domain)) {
    cook <- sprintf(
      "%s Domain = %s;",
      cook,
      check_cookie_part(as.character(domain), "domain", cookie_value_ok)
    )
  }

  if (!is.null(path)) {
    cook <- sprintf(
      "%s Path = %s;",
      cook,
      check_cookie_part(as.character(path), "path", cookie_value_ok)
    )
  }

  if (!is.null(secure) && secure) {
    cook <- sprintf(
      "%s Secure;",
      cook
    )
  }

  if (!is.null(http_only) && http_only) {
    cook <- sprintf(
      "%s HttpOnly;",
      cook
    )
  }

  if (!is.null(same_site)) {
    attempt::stop_if_not(
      same_site,
      ~ .x %in% c("Strict", "Lax", "None"),
      'same_site should be one of "Strict", "Lax", "None"'
    )
    cook <- sprintf(
      "%s SameSite = %s;",
      cook,
      same_site
    )
  }

  res$headers$`Set-Cookie` <- cook
  res
}

#' @export
#' @rdname cookie-middleware
remove_cookie <- function(
  res,
  name,
  path = NULL,
  domain = NULL
) {
  # A cookie is only replaced when name, path and domain all match, so a
  # deletion has to repeat whatever `set_cookie()` was given. Without them the
  # browser scopes the deletion to the directory of the current request, which
  # silently misses a cookie set with an explicit path -- and behind a mount,
  # that directory is not "/".
  cook <- sprintf(
    "%s=; Max-Age=0;",
    check_cookie_part(as.character(name), "name", cookie_token_ok)
  )

  if (!is.null(domain)) {
    cook <- sprintf(
      "%s Domain = %s;",
      cook,
      check_cookie_part(as.character(domain), "domain", cookie_value_ok)
    )
  }

  if (!is.null(path)) {
    cook <- sprintf(
      "%s Path = %s;",
      cook,
      check_cookie_part(as.character(path), "path", cookie_value_ok)
    )
  }

  res$headers$`Set-Cookie` <- cook
  res
}

# HTTP Date is stupid
# https://developer.mozilla.org/fr/docs/Web/HTTP/Headers/Date
http_date <- function(date) {
  # Borrowed from https://github.com/r-lib/gargle/blob/132d549871ab5d80ae20d21c5b465fdd80ca0f6c/R/shiny.R#L250
  sprintf(
    "%s, %02s %s %04s %02s:%02s:%02s GMT",
    c(
      "Mon",
      "Tue",
      "Wed",
      "Thu",
      "Fri",
      "Sat",
      "Sun"
    )[
      date$wday + 1
    ],
    date$mday,
    c(
      "Jan",
      "Feb",
      "Mar",
      "Apr",
      "May",
      "Jun",
      "Jul",
      "Aug",
      "Sep",
      "Oct",
      "Nov",
      "Dec"
    )[
      date$mon + 1
    ],
    date$year + 1900,
    date$hour,
    date$min,
    date$sec
  )
}