beatrina 0.8.6

package/failsafe/cite.R

@@ -0,0 +1,418 @@
+# cite.R — citations rendered by pandoc, in the style the document chose.
+#
+# The notebook shows citations live: the (Author, Year) in prose, the
+# References section after the last cell, the knitted bibliography. Until
+# 7.18 every one of them was drawn by the page in an APA shape, because a
+# CSL engine is a megabyte and the page must stay small. The decision that
+# replaced it — the owner's, 2026-09-04: "implement the most common ones,
+# rely on pandoc, and that is it, to avoid bloat" — is what this file does.
+# Six CSL files ship BESIDE the kernel (plugins/csl/, 324 KB the page never
+# loads), pandoc's own citeproc renders with them, and the page inserts what
+# comes back. No engine in the page. Any other style is a PLUGIN — found in
+# the CSL repository and imported through spike/plugins.R's one door.
+#
+# Everything here is pure or takes its inputs explicitly (`here`, the
+# request), so spike/test-cite.R can drive it without a socket. serve.R owns
+# the socket rules: `cite` is page-only and agent-refused — it spawns a
+# process on request, and a process this supervisor starts is the person's
+# to start — while `cite_styles` is open to any socket (it discloses six
+# file names and a version, nothing else).
+#
+# What pandoc is given, and what it is not. The page sends the cited entries
+# as CSL-YAML (the same `references:` block the .carmd keeps) and the
+# citation groups in document order; the supervisor writes ONE markdown
+# file — the YAML as front matter, one paragraph per group — and runs pandoc
+# over it with `--sandbox`, so a hostile field cannot make pandoc read a
+# file, and with raw HTML disabled in the reader, so a title cannot smuggle
+# markup through metadata. The page scrubs the HTML it gets back all the
+# same (lib/cite-styles.js): two doors, because a title is imported data
+# from someone's .bib and never trusted on either side. Bounded on every
+# axis a request has: bytes of YAML, number of groups, keys per group, key
+# alphabet, one run at a time per socket, a wall-clock timeout that kills
+# the process group.
+
+CITE_MAX_YAML_BYTES <- 1000000L
+CITE_MAX_GROUPS <- 2000L
+CITE_MAX_KEYS_PER_GROUP <- 50L
+CITE_TIMEOUT_MS <- 20000L
+# pandoc's citation-key alphabet (the page's CITE_KEY, restated in R): word
+# characters, then internal punctuation, never a final one.
+CITE_KEY_RE <- "^[A-Za-z0-9_]([A-Za-z0-9_:.#$%&+?<>~/-]*[A-Za-z0-9_])?$"
+
+# ── the styles are PLUGINS (spike/plugins.R) ─────────────────────────────
+#
+# A style is one plugin of kind `csl`: a folder holding `<id>.csl` and its
+# manifest, in one of three layers — the person's own (what the picker
+# imports from the CSL project's repository, ~10,900 styles), an
+# administrator's `CARMAR_PLUGIN_DIR`, and the six shipped beside the kernel
+# (plugins/csl/). plugins.R owns the layers, the manifest, the integrity
+# check, the atomic install and the policy; this file owns what a CSL file
+# IS (its title, its parent), the repository search, and pandoc. On the wire
+# a style is still `<id>.csl` — the value `csl:` carries in a document's
+# front matter — so the page and the saved files know nothing of folders.
+# Nothing here runs at start: the index is fetched on the first search of a
+# session, a style on the click that imports it, both through the policy's
+# host list.
+
+CSL_INDEX_URL <- function() Sys.getenv("CARMAR_CSL_INDEX_URL", "https://www.zotero.org/styles-files/styles.json")
+CSL_STYLE_BASE <- function() Sys.getenv("CARMAR_CSL_STYLE_BASE", "https://www.zotero.org/styles/")
+CSL_MAX_INDEX_BYTES <- 8000000
+CSL_INDEX_MAX_AGE_DAYS <- 7
+CSL_SEARCH_LIMIT <- 40L
+# The repository's own name alphabet (measured over all 10,861 entries: only
+# [a-z0-9.-], longest 119). Narrower than a plugin id, which is what the
+# repository door checks against — a URL or file door uses PLUGIN_ID_RE.
+CSL_NAME_RE <- "^[a-z0-9][a-z0-9.-]{0,118}$"
+CSL_NS <- "http://purl.org/net/xbiblio/csl"
+
+csl_cache_dir <- function() tools::R_user_dir("carmar", "cache")
+
+#' A style's own <title>, and the parent a DEPENDENT style names.
+#'
+#' Read as text from the head of the file — a full XML parse of Chicago
+#' (164 KB) for two lines is not worth a dependency. A dependent style is
+#' metadata only (title, category, a link to its parent); the formatting is
+#' entirely the parent's.
+csl_info <- function(path) {
+  head_text <- tryCatch(paste(readLines(path, n = 60L, warn = FALSE, encoding = "UTF-8"), collapse = "\n"),
+                        error = function(e) "")
+  title <- regmatches(head_text, regexpr("<title>[^<]+</title>", head_text))
+  title <- if (length(title)) trimws(sub("</title>$", "", sub("^<title>", "", title[[1L]]))) else ""
+  # The five XML entities, decoded: a title is shown as text, and
+  # "Taylor &amp; Francis" is not a name.
+  for (ent in list(c("&lt;", "<"), c("&gt;", ">"), c("&quot;", "\""), c("&apos;", "'"), c("&amp;", "&"))) {
+    title <- gsub(ent[[1L]], ent[[2L]], title, fixed = TRUE)
+  }
+  parent <- regmatches(head_text, regexpr('<link[^>]*rel="independent-parent"[^>]*/?>', head_text))
+  parent_name <- ""
+  if (length(parent)) {
+    href <- regmatches(parent[[1L]], regexpr('href="[^"]+"', parent[[1L]]))
+    if (length(href)) parent_name <- basename(sub('"$', "", sub('^href="', "", href[[1L]])))
+  }
+  parent_name <- sub("\\.csl$", "", parent_name)
+  list(title = title, parent = if (nzchar(parent_name)) paste0(parent_name, ".csl") else "")
+}
+
+#' Is this file a CSL style? The root element, in the CSL namespace, with a
+#' title — checked on the head of the file. Not a schema validation;
+#' pandoc's own parser is the judge of the rest, and refuses cleanly.
+csl_looks_like_style <- function(path) {
+  head_text <- tryCatch(paste(readLines(path, n = 40L, warn = FALSE, encoding = "UTF-8"), collapse = "\n"),
+                        error = function(e) "")
+  grepl("<style[ >]", head_text, fixed = FALSE) && grepl(CSL_NS, head_text, fixed = TRUE) &&
+    !grepl("<!DOCTYPE|<!ENTITY", head_text) && nzchar(csl_info(path)$title)
+}
+
+#' Every style this kernel can render with: the ACTIVE csl plugins.
+#'
+#' READ from the store, never declared — a style staged beside the kernel is
+#' offered the moment it is there, an imported one the moment it is
+#' written, and one whose file no longer matches its manifest is absent
+#' from this list rather than promised and broken.
+#'
+#' @return data.frame(file, name, layer, dependent_on, path)
+csl_styles <- function(here, policy) {
+  rows <- plugin_rows(here, policy, "csl")
+  rows <- rows[rows$active, , drop = FALSE]
+  data.frame(
+    file = rows$file,
+    name = ifelse(nzchar(rows$name), rows$name, rows$id),
+    layer = rows$layer,
+    dependent_on = ifelse(nzchar(rows$requires), paste0(sub(";.*$", "", rows$requires), ".csl"), ""),
+    path = ifelse(nzchar(rows$dir), file.path(rows$dir, rows$file), ""),
+    stringsAsFactors = FALSE)
+}
+
+#' The .csl file a request may name, resolved in a layer or refused.
+#'
+#' A bare file name from the list, nothing else: no path separators, no
+#' `..`, no absolute path. "default" (or nothing) means pandoc's built-in
+#' Chicago author-date, which needs no file at all.
+#'
+#' @return The absolute path, "" for the default, or NULL when refused.
+csl_resolve <- function(here, policy, style) {
+  if (is.null(style) || identical(style, "") || identical(style, "default")) return("")
+  if (!is.character(style) || length(style) != 1L || is.na(style)) return(NULL)
+  if (!grepl("\\.csl$", style) || !plugin_id_ok(sub("\\.csl$", "", style))) return(NULL)
+  styles <- csl_styles(here, policy)
+  row <- styles[styles$file == style, , drop = FALSE]
+  if (!nrow(row)) return(NULL)
+  normalizePath(row$path[[1L]], mustWork = FALSE)
+}
+
+#' The file pandoc is actually handed: a dependent style's PARENT, resolved
+#' locally in any layer — pandoc would otherwise go looking for it, which
+#' the sandbox forbids. The formatting of a dependent style IS its parent's.
+#'
+#' @return The path to render with, or NULL when a dependent's parent is
+#'   not on this machine.
+csl_engine_path <- function(here, policy, path) {
+  if (is.null(path) || !nzchar(path)) return(path)
+  parent <- csl_info(path)$parent
+  if (!nzchar(parent)) return(path)
+  csl_resolve(here, policy, parent)
+}
+
+# The repository index, once per session (and on disk for a week, so a
+# second session searches without a fetch).
+.csl_index_cache <- new.env(parent = emptyenv())
+
+csl_index <- function(policy) {
+  if (!is.null(.csl_index_cache$rows)) return(.csl_index_cache$rows)
+  dir <- csl_cache_dir()
+  disk <- file.path(dir, "csl-index.json")
+  fresh <- file.exists(disk) &&
+    as.numeric(difftime(Sys.time(), file.info(disk)$mtime, units = "days")) < CSL_INDEX_MAX_AGE_DAYS
+  if (!fresh) {
+    dir.create(dir, recursive = TRUE, showWarnings = FALSE, mode = "0700")
+    tmp <- tempfile("csl-index-", fileext = ".json")
+    err <- plugin_fetch(policy, CSL_INDEX_URL(), tmp, CSL_MAX_INDEX_BYTES)
+    if (nzchar(err)) {
+      if (!file.exists(disk)) return(structure(list(), error = paste0("The style index could not be fetched: ", err)))
+    } else {
+      file.copy(tmp, disk, overwrite = TRUE); unlink(tmp); Sys.chmod(disk, "0600")
+    }
+  }
+  raw <- tryCatch(jsonlite::fromJSON(disk, simplifyVector = TRUE), error = function(e) NULL)
+  if (!is.data.frame(raw) || !all(c("name", "title") %in% names(raw))) {
+    return(structure(list(), error = "The style index did not read as a list of styles."))
+  }
+  fmt <- if (is.data.frame(raw$categories) && "format" %in% names(raw$categories)) raw$categories$format else rep("", nrow(raw))
+  rows <- data.frame(
+    name = as.character(raw$name), title = as.character(raw$title),
+    dependent = if ("dependent" %in% names(raw)) as.integer(raw$dependent) == 1L else rep(FALSE, nrow(raw)),
+    format = ifelse(is.na(fmt), "", as.character(fmt)),
+    stringsAsFactors = FALSE)
+  rows <- rows[grepl(CSL_NAME_RE, rows$name) & nzchar(rows$title), , drop = FALSE]
+  .csl_index_cache$rows <- rows
+  rows
+}
+
+#' Search the repository index: every term must appear in the title or the
+#' name, case-insensitively; titles that START with the query come first.
+#' @return list(ok, total, rows = list of {name, title, dependent, format}) or list(ok = FALSE, error)
+csl_search <- function(policy, q, limit = CSL_SEARCH_LIMIT) {
+  q <- trimws(if (is.character(q) && length(q) == 1L && !is.na(q)) q else "")
+  if (nchar(q) < 2L) return(list(ok = TRUE, total = 0L, rows = list()))
+  if (!isTRUE(policy$network)) return(list(ok = FALSE, error = plugin_policy_reason(policy, "network")))
+  idx <- csl_index(policy)
+  if (!is.null(attr(idx, "error"))) return(list(ok = FALSE, error = attr(idx, "error")))
+  terms <- strsplit(tolower(q), "\\s+")[[1L]]
+  hay <- tolower(paste(idx$title, idx$name))
+  hit <- Reduce(`&`, lapply(terms, function(t) grepl(t, hay, fixed = TRUE)), rep(TRUE, length(hay)))
+  found <- idx[hit, , drop = FALSE]
+  starts <- startsWith(tolower(found$title), tolower(q))
+  found <- found[order(!starts, found$dependent, tolower(found$title)), , drop = FALSE]
+  shown <- head(found, limit)
+  list(ok = TRUE, total = nrow(found),
+       rows = lapply(seq_len(nrow(shown)), function(i) list(
+         name = shown$name[[i]], title = shown$title[[i]],
+         dependent = isTRUE(shown$dependent[[i]]), format = shown$format[[i]])))
+}
+
+#' Import one style from the repository: `plugin_install` by registry name.
+#' A dependent style brings its parent along (the store completes it), so
+#' rendering never needs the network again.
+#'
+#' @return list(ok = TRUE, file, name, dependent_on, already) or list(ok = FALSE, error)
+csl_import <- function(here, policy, name) {
+  if (!is.character(name) || length(name) != 1L || is.na(name) || !grepl(CSL_NAME_RE, name)) {
+    return(list(ok = FALSE, error = "That is not a style name from the repository."))
+  }
+  r <- plugin_install(here, policy, "csl", list(registry = name))
+  if (!isTRUE(r$ok)) return(r)
+  list(ok = TRUE, file = r$file, name = r$name,
+       dependent_on = if (length(r$requires)) paste0(r$requires[[1L]], ".csl") else "",
+       already = isTRUE(r$already))
+}
+
+#' Remove a style from the user layer — `plugin_remove`, by file name.
+csl_remove <- function(here, policy, file) {
+  if (!is.character(file) || length(file) != 1L || is.na(file) || !grepl("\\.csl$", file) ||
+      !plugin_id_ok(sub("\\.csl$", "", file))) {
+    return(list(ok = FALSE, error = "That is not a style file name."))
+  }
+  r <- plugin_remove(here, policy, "csl", sub("\\.csl$", "", file))
+  if (!isTRUE(r$ok)) return(r)
+  list(ok = TRUE, file = file)
+}
+
+#' Locate pandoc, the same ladder shape find_quarto() climbs: an explicit
+#' override, what RStudio sets, rmarkdown's own answer, PATH, then the
+#' bundles known by name. Measured on a normal RStudio machine: no pandoc on
+#' PATH, one inside RStudio's Quarto.
+#' @return Path to pandoc, or "".
+find_pandoc <- function() {
+  explicit <- Sys.getenv("CARMAR_PANDOC", "")
+  if (nzchar(explicit) && file.exists(explicit)) return(explicit)
+  from_env <- Sys.getenv("RSTUDIO_PANDOC", "")
+  if (nzchar(from_env)) {
+    cand <- file.path(from_env, if (.Platform$OS.type == "windows") "pandoc.exe" else "pandoc")
+    if (file.exists(cand)) return(cand)
+  }
+  if (requireNamespace("rmarkdown", quietly = TRUE)) {
+    found <- tryCatch(rmarkdown::pandoc_exec(), error = function(e) NULL)
+    if (!is.null(found) && nzchar(found) && file.exists(found)) return(found)
+  }
+  on_path <- unname(Sys.which("pandoc"))
+  if (nzchar(on_path)) return(on_path)
+  arch <- if (grepl("aarch64|arm64", R.version$arch)) "aarch64" else "x86_64"
+  bundles <- c(
+    file.path("/Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools", arch, "pandoc"),
+    file.path("/Applications/Positron.app/Contents/Resources/app/quarto/bin/tools", arch, "pandoc"),
+    file.path("/Applications/quarto/bin/tools", arch, "pandoc"),
+    "/usr/local/bin/pandoc", "/opt/homebrew/bin/pandoc",
+    "C:/Program Files/RStudio/resources/app/bin/quarto/bin/tools/pandoc.exe",
+    "C:/Program Files/Pandoc/pandoc.exe"
+  )
+  hit <- Find(file.exists, bundles)
+  if (is.null(hit)) "" else hit
+}
+
+#' pandoc's version, or "" when it is absent or does not answer.
+pandoc_version <- function(bin) {
+  if (!nzchar(bin)) return("")
+  ran <- tryCatch(processx::run(bin, "--version", timeout = 5, error_on_status = FALSE),
+                  error = function(e) NULL)
+  if (is.null(ran) || !identical(as.integer(ran$status), 0L)) return("")
+  first <- strsplit(ran$stdout %||% "", "\n", fixed = TRUE)[[1L]][1L]
+  trimws(sub("^pandoc\\s+", "", first %||% ""))
+}
+
+#' Validate a `cite` request. The whole contract, in one place.
+#'
+#' @param cmd The parsed frame: `yaml` (the CSL-YAML `references:` block),
+#'   `groups` (a list of {keys: character, narrative: logical}), `style`.
+#' @return list(ok = TRUE, yaml, groups, style) or list(ok = FALSE, error).
+cite_validate <- function(here, policy, cmd) {
+  refuse <- function(msg) list(ok = FALSE, error = msg)
+  yaml <- cmd$yaml
+  if (!is.character(yaml) || length(yaml) != 1L || is.na(yaml)) return(refuse("cite: `yaml` must be a string."))
+  if (nchar(yaml, type = "bytes") > CITE_MAX_YAML_BYTES) return(refuse("cite: the reference block is too large."))
+  # The block is one YAML document whose only top-level key is `references:`.
+  # A second top-level key would be metadata injection — a `csl:` or
+  # `bibliography:` smuggled in by a field — so the first line is pinned and
+  # every later line must be indented or a list item.
+  lines <- strsplit(yaml, "\n", fixed = TRUE)[[1L]]
+  if (!length(lines) || !identical(trimws(lines[[1L]]), "references:")) {
+    return(refuse("cite: the reference block must start with `references:`."))
+  }
+  rest <- lines[-1L]
+  bad <- rest[nzchar(trimws(rest)) & !grepl("^( |-)", rest)]
+  if (length(bad)) return(refuse("cite: the reference block carries a key that is not a reference."))
+  style <- csl_resolve(here, policy, cmd$style)
+  if (is.null(style)) return(refuse("cite: that style is not one this kernel has."))
+  style <- csl_engine_path(here, policy, style)
+  if (is.null(style)) return(refuse("cite: that style depends on a parent style that is not on this machine."))
+  groups <- cmd$groups
+  if (is.null(groups)) groups <- list()
+  if (is.data.frame(groups)) {
+    # jsonlite simplifies a uniform list of objects into a data.frame.
+    groups <- lapply(seq_len(nrow(groups)), function(i) list(
+      keys = groups$keys[[i]], narrative = groups$narrative[[i]]))
+  }
+  if (!is.list(groups)) return(refuse("cite: `groups` must be a list."))
+  if (length(groups) > CITE_MAX_GROUPS) return(refuse("cite: too many citations in one request."))
+  clean <- vector("list", length(groups))
+  for (i in seq_along(groups)) {
+    g <- groups[[i]]
+    keys <- as.character(unlist(g$keys %||% character()))
+    if (!length(keys) || length(keys) > CITE_MAX_KEYS_PER_GROUP) {
+      return(refuse("cite: a citation must name between one and fifty keys."))
+    }
+    if (!all(grepl(CITE_KEY_RE, keys))) return(refuse("cite: a citation key has characters pandoc would not read."))
+    clean[[i]] <- list(keys = keys, narrative = isTRUE(g$narrative))
+  }
+  list(ok = TRUE, yaml = yaml, groups = clean, style = style)
+}
+
+#' The markdown pandoc renders: front matter, then one paragraph per group.
+#'
+#' Each paragraph is wrapped in a span with a known class so the answer can
+#' be split back into groups by position, whatever the style did inside.
+cite_document <- function(yaml, groups) {
+  paras <- vapply(groups, function(g) {
+    cite <- if (g$narrative) paste0("@", g$keys[[1L]])
+            else paste0("[", paste0("@", g$keys, collapse = "; "), "]")
+    paste0("[", cite, "]{.carmar-cite-group}")
+  }, character(1))
+  paste0("---\n", yaml, "\n---\n\n", paste(paras, collapse = "\n\n"), "\n")
+}
+
+#' Split pandoc's HTML into the group labels and the bibliography.
+#'
+#' Positional: the i-th `carmar-cite-group` span is the i-th group. The
+#' bibliography is pandoc's `<div id="refs">`, whole. Anything else pandoc
+#' printed is dropped.
+cite_split <- function(html, n_groups) {
+  labels <- character(n_groups)
+  # A group span holds no nested span of its own class, so a non-greedy
+  # match to the first closing </span> after the citation's inner spans is
+  # wrong; count nesting instead by walking span tags.
+  starts <- gregexpr('<span class="carmar-cite-group">', html, fixed = TRUE)[[1L]]
+  if (starts[[1L]] != -1L) {
+    for (i in seq_len(min(length(starts), n_groups))) {
+      from <- starts[[i]] + nchar('<span class="carmar-cite-group">')
+      rest <- substring(html, from)
+      depth <- 1L
+      pos <- 0L
+      tags <- gregexpr("<span\\b[^>]*>|</span>", rest)[[1L]]
+      lens <- attr(tags, "match.length")
+      for (j in seq_along(tags)) {
+        if (tags[[j]] == -1L) break
+        tag <- substring(rest, tags[[j]], tags[[j]] + lens[[j]] - 1L)
+        depth <- depth + if (startsWith(tag, "</")) -1L else 1L
+        if (depth == 0L) { pos <- tags[[j]]; break }
+      }
+      labels[[i]] <- if (pos > 0L) substring(rest, 1L, pos - 1L) else ""
+    }
+  }
+  refs <- ""
+  at <- regexpr('<div id="refs"', html, fixed = TRUE)
+  if (at != -1L) {
+    tail <- substring(html, at)
+    # The refs div closes at the last </div> of the document pandoc printed
+    # (nothing follows it in a body-only render).
+    ends <- gregexpr("</div>", tail, fixed = TRUE)[[1L]]
+    if (ends[[1L]] != -1L) refs <- substring(tail, 1L, ends[[length(ends)]] + 5L)
+  }
+  list(labels = labels, bibliography = refs)
+}
+
+#' Run pandoc over one validated request.
+#'
+#' @return list(ok, labels, bibliography, engine) or list(ok = FALSE, error).
+cite_run <- function(bin, valid, timeout_ms = CITE_TIMEOUT_MS) {
+  if (!nzchar(bin)) return(list(ok = FALSE, error = "pandoc is not installed, or CarmaR could not find it."))
+  input <- tempfile("carmar-cite-", fileext = ".md")
+  on.exit(unlink(input), add = TRUE)
+  writeLines(cite_document(valid$yaml, valid$groups), input, useBytes = TRUE)
+  Sys.chmod(input, "0600")
+  args <- c(
+    # raw_html and raw_tex OFF in the reader: a title in the metadata is
+    # parsed as markdown, and raw HTML in it would otherwise pass straight
+    # through to the output. Smart quotes on, as in every render.
+    "--from", "markdown-raw_html-raw_tex",
+    "--to", "html", "--citeproc", "--wrap", "none", "--sandbox",
+    # A citation to a key the block does not hold must still render as
+    # SOMETHING (pandoc prints `[@key]` with a warning) rather than fail.
+    input
+  )
+  if (nzchar(valid$style)) args <- c(args, paste0("--csl=", valid$style))
+  ran <- tryCatch(processx::run(
+    bin, args, timeout = timeout_ms / 1000, error_on_status = FALSE, echo = FALSE,
+    cleanup_tree = TRUE, env = c("current", PANDOC_DATA_DIR = tempdir(), HOME = tempdir())
+  ), error = function(e) e)
+  if (inherits(ran, "error")) {
+    msg <- if (grepl("timeout", conditionMessage(ran), ignore.case = TRUE))
+      "pandoc took too long and was stopped." else conditionMessage(ran)
+    return(list(ok = FALSE, error = paste0("cite: ", msg)))
+  }
+  if (isTRUE(ran$timeout)) return(list(ok = FALSE, error = "cite: pandoc took too long and was stopped."))
+  if (!identical(as.integer(ran$status), 0L)) {
+    first <- strsplit(ran$stderr %||% "", "\n", fixed = TRUE)[[1L]][1L] %||% ""
+    return(list(ok = FALSE, error = paste0("cite: pandoc exited ", ran$status, if (nzchar(first)) paste0(": ", first) else "")))
+  }
+  parts <- cite_split(ran$stdout %||% "", length(valid$groups))
+  list(ok = TRUE, labels = parts$labels, bibliography = parts$bibliography)
+}