R/record.R

In zumime: Media Type Detection from Bytes and File Names

#' Parse and serialise MIME types
#'
#' `mime_parse()` is the WHATWG MIME Sniffing Standard's "parse a MIME
#' type". Type and subtype are lower-cased HTTP tokens. Parameters keep
#' their order, and their names are lower-cased. Quoted values are
#' unescaped. A repeated name keeps its first value. `mime_format()` is
#' "serialize a MIME type". It quotes a value that is empty or not a token.
#'
#' `mime_format()` checks a record before serialising it, so an edited
#' record cannot carry a line break into a header. Type, subtype and
#' parameter names must be non-empty HTTP tokens. Values must hold only HTTP
#' quoted-string token code points: tab, U+0020 to U+007E and U+0080 to
#' U+00FF. A record that breaks this raises `zumime_type_error`.
#'
#' @param x A character vector of MIME types, such as `Content-Type`
#'   header values.
#' @param strict If `TRUE`, an input that fails to parse raises
#'   `zumime_parse_error` instead of giving `NULL`.
#' @return `mime_parse()` returns a list with one record per input: a list
#'   of `type`, `subtype` and `parameters` (a named list of strings), or
#'   `NULL` for input that fails to parse and for `NA`.
#'
#'   `mime_format()` returns a character vector, `NA` for a `NULL` record.
#' @references <https://mimesniff.spec.whatwg.org/#parsing-a-mime-type>
#' @seealso [mime_sniff()], which takes a supplied type in this grammar.
#' @export
#' @examples
#' rec <- mime_parse("Text/HTML; Charset=\"UTF-8\"; charset=latin1")
#' str(rec)
#' mime_format(rec)
#' mime_format(mime_parse("text/plain;name=\"a b\""))
#' mime_parse("not a type")
mime_parse <- function(x, strict = FALSE) {
  x <- check_character(x)
  check_flag(strict)
  out <- .Call(zumime_mime_parse, utf8_or_replace(x))
  if (strict) {
    bad <- which(vapply(out, is.null, logical(1)) & !is.na(x))
    if (length(bad) > 0) {
      zumime_abort(
        "parse",
        sprintf(
          "Input %d is not a valid MIME type: \"%s\".",
          bad[1],
          x[bad[1]]
        )
      )
    }
  }
  out
}

#' @param record One record from `mime_parse()`, or a list of them.
#' @rdname mime_parse
#' @export
mime_format <- function(record) {
  if (is_record(record)) {
    record <- list(record)
  }
  if (
    !is.list(record) ||
      !all(vapply(record, function(r) is.null(r) || is_record(r), logical(1)))
  ) {
    zumime_abort(
      "type",
      "`record` must be a record from `mime_parse()` or a list of them."
    )
  }
  for (i in seq_along(record)) {
    if (!is.null(record[[i]]) && !is_valid_record(record[[i]])) {
      zumime_abort(
        "type",
        sprintf(
          paste(
            "Record %d holds a type, subtype or parameter name that is not",
            "an HTTP token, or a value outside the quoted-string code points."
          ),
          i
        )
      )
    }
  }
  record <- lapply(record, function(r) {
    if (is.null(r)) {
      return(NULL)
    }
    p <- r[["parameters"]]
    list(
      enc2utf8(r[["type"]]),
      enc2utf8(r[["subtype"]]),
      structure(
        lapply(p, enc2utf8),
        names = enc2utf8(names(p) %||% character())
      )
    )
  })
  .Call(zumime_mime_format, record)
}

# A record as mime_parse() makes it, by shape. Fields are read with [[ so a
# list with `typex` is not taken for one with `type`. is_valid_record()
# checks the contents.
is_record <- function(r) {
  is.list(r) &&
    is_string(r[["type"]]) &&
    is_string(r[["subtype"]]) &&
    is.list(r[["parameters"]]) &&
    all(vapply(r[["parameters"]], is_string, logical(1))) &&
    (length(r[["parameters"]]) == 0L || !is.null(names(r[["parameters"]])))
}

# The WHATWG serialiser assumes a valid record: tokens for type, subtype
# and names, HTTP quoted-string token code points for values. Without the
# check, a CR or LF in an edited record reaches a header verbatim.
is_valid_record <- function(r) {
  p <- r[["parameters"]]
  is_http_token(c(r[["type"]], r[["subtype"]], names(p))) &&
    all(vapply(p, is_quoted_token_string, logical(1)))
}

is_http_token <- function(x) {
  all(grepl("^[-!#$%&'*+.^_`|~0-9A-Za-z]+$", x, perl = TRUE))
}

# Tab, U+0020 to U+007E and U+0080 to U+00FF. utf8ToInt() gives NA for
# invalid UTF-8, which is no code point.
is_quoted_token_string <- function(v) {
  cp <- utf8ToInt(enc2utf8(v))
  !anyNA(cp) && all(cp == 0x09L | (cp >= 0x20L & cp != 0x7FL & cp <= 0xFFL))
}

# x in UTF-8 for the parser. enc2utf8() turns a byte the native encoding
# cannot hold into the text "<c3>", which then parses as a value; the
# standard decodes it to U+FFFD, which no token or value may hold.
utf8_or_replace <- function(x) {
  x <- bytes_to_utf8(x)
  bad <- !is.na(x) & Encoding(x) == "unknown" & !validUTF8(x)
  # U+FFFD as bytes: as a string it would be translated to the native
  # encoding, which may not hold it.
  fffd <- rawToChar(as.raw(c(0xef, 0xbf, 0xbd)))
  x[bad] <- iconv(x[bad], "", "UTF-8", sub = fffd)
  Encoding(x[bad]) <- "UTF-8"
  enc2utf8(x)
}