Add a transactional R and Shiny poll workbench

.github/workflows/poll-studio.yml

@@ -0,0 +1,39 @@
+name: Poll Studio checks
+
+on:
+  pull_request:
+    paths:
+      - 'applications/poll-studio/**'
+      - '.github/workflows/poll-studio.yml'
+  push:
+    branches: [main]
+    paths:
+      - 'applications/poll-studio/**'
+      - '.github/workflows/poll-studio.yml'
+  workflow_dispatch:
+
+permissions:
+  contents: read
+
+jobs:
+  check:
+    runs-on: ubuntu-latest
+    defaults:
+      run:
+        working-directory: applications/poll-studio
+    steps:
+      - uses: actions/checkout@3d3c42e5aac5ba805825da76410c181273ba90b1 # v7.0.1
+      - uses: r-lib/actions/setup-r@f9a764fea8d5c63df6ef9a5c7795bf7deb5d7e05 # v2
+        with:
+          r-version: '4.6.1'
+          use-public-rspm: false
+      - name: Install native package and graphics prerequisites
+        run: |
+          sudo apt-get update
+          sudo apt-get install -y libpq-dev libcurl4-openssl-dev libssl-dev libxml2-dev \
+            libuv1-dev libcairo2-dev libpango1.0-dev libpng-dev libjpeg-dev libtiff-dev cmake
+      - run: Rscript -e 'renv::restore(prompt = FALSE)'
+      - run: Rscript -e 'stopifnot(capabilities("png"), capabilities("cairo")); for (p in c("app.R", "run.R", list.files("R", full.names=TRUE), list.files("test", pattern="\\.R$", full.names=TRUE))) parse(p)'
+      - run: Rscript test/domain.R
+
+# Dedicated Cloud and browser checks run separately without CI credentials.

applications/poll-studio/.R-version

@@ -0,0 +1 @@
+4.6.1

applications/poll-studio/.Rprofile

@@ -0,0 +1 @@
+source("renv/activate.R")

applications/poll-studio/.env.example

@@ -0,0 +1,8 @@
+PGHOST=your-cloud-hostname
+PGPORT=5432
+PGDATABASE=postgres
+PGUSER=polls_app
+PGPASSWORD=your-runtime-role-password
+PGSSLROOTCERT=/absolute/path/cloud-ca.pem
+APP_ORIGIN=http://127.0.0.1:4000
+PORT=4000

applications/poll-studio/.gitignore

@@ -0,0 +1,8 @@
+.env
+*.pem
+.Rhistory
+.RData
+renv/library/
+renv/staging/
+renv/cache/
+node_modules/

applications/poll-studio/R/database.R

@@ -0,0 +1,19 @@
+required_env <- function(name) {
+  value <- Sys.getenv(name, unset = "")
+  if (!nzchar(value)) stop(paste("Missing configuration:", name), call. = FALSE)
+  value
+}
+
+connection_options <- function() {
+  list(drv = RPostgres::Postgres(), host = required_env("PGHOST"),
+       port = required_env("PGPORT"), dbname = required_env("PGDATABASE"),
+       user = required_env("PGUSER"), password = required_env("PGPASSWORD"),
+       sslmode = "verify-full", sslrootcert = required_env("PGSSLROOTCERT"),
+       connect_timeout = "10", bigint = "character", timezone = "UTC",
+       application_name = "poll-studio",
+       options = "-c statement_timeout=5000 -c lock_timeout=3000 -c idle_in_transaction_session_timeout=5000")
+}
+
+new_pool <- function() {
+  do.call(pool::dbPool, c(connection_options(), list(minSize = 1L, maxSize = 4L)))
+}

applications/poll-studio/R/polls.R

@@ -0,0 +1,80 @@
+create_poll <- function(db, question, choices) {
+  input <- validate_poll(question, choices)
+  pool::poolWithTransaction(db, function(conn) {
+    row <- DBI::dbGetQuery(conn,
+      "INSERT INTO poll_studio.polls (question) VALUES ($1) RETURNING id::text AS id",
+      params = list(input$question))
+    for (position in seq_along(input$choices)) {
+      DBI::dbExecute(conn,
+        "INSERT INTO poll_studio.choices (poll_id, position, label) VALUES ($1::bigint, $2, $3)",
+        params = list(row$id[[1]], position, input$choices[[position]]))
+    }
+    row$id[[1]]
+  })
+}
+
+list_polls <- function(db) {
+  DBI::dbGetQuery(db,
+    "SELECT id::text AS id, question, closed_at IS NOT NULL AS closed, response_count,
+       created_at FROM poll_studio.polls ORDER BY created_at DESC, poll_studio.polls.id DESC LIMIT 100")
+}
+
+poll_summary <- function(db, poll_id) {
+  poll_id <- identifier(poll_id)
+  DBI::dbGetQuery(db,
+    "SELECT p.id::text AS poll_id, p.question, p.closed_at IS NOT NULL AS closed,
+       p.response_count, c.id::text AS choice_id, c.label, c.position,
+       count(r.id)::integer AS responses
+     FROM poll_studio.polls p JOIN poll_studio.choices c ON c.poll_id = p.id
+       LEFT JOIN poll_studio.responses r ON r.poll_id = c.poll_id AND r.choice_id = c.id
+     WHERE p.id = $1::bigint
+     GROUP BY p.id, c.id ORDER BY c.position", params = list(poll_id))
+}
+
+record_response <- function(db, poll_id, choice_id, code) {
+  poll_id <- identifier(poll_id)
+  choice_id <- identifier(choice_id)
+  code <- participant_code(code)
+  pool::poolWithTransaction(db, function(conn) {
+    poll <- DBI::dbGetQuery(conn,
+      "SELECT closed_at IS NOT NULL AS closed, response_count FROM poll_studio.polls
+       WHERE id = $1::bigint FOR UPDATE", params = list(poll_id))
+    if (nrow(poll) == 0L) poll_error("Poll does not exist.", "missing")
+    retained <- DBI::dbGetQuery(conn,
+      "SELECT id::text AS id, choice_id::text AS choice_id FROM poll_studio.responses
+       WHERE poll_id = $1::bigint AND participant_code = $2", params = list(poll_id, code))
+    if (nrow(retained) > 0L) {
+      if (!identical(retained$choice_id[[1]], choice_id)) {
+        poll_error("This code already selected a different choice.", "conflict")
+      }
+      return(list(id = retained$id[[1]], replayed = TRUE))
+    }
+    if (poll$closed[[1]]) poll_error("Poll is closed; matching saved responses can still replay.", "conflict")
+    if (poll$response_count[[1]] >= 10000L) poll_error("This poll reached its 10,000-response limit.", "conflict")
+    choice <- DBI::dbGetQuery(conn,
+      "SELECT id FROM poll_studio.choices WHERE poll_id = $1::bigint AND id = $2::bigint",
+      params = list(poll_id, choice_id))
+    if (nrow(choice) == 0L) poll_error("Choice does not belong to this poll.")
+    DBI::dbExecute(conn,
+      "UPDATE poll_studio.polls SET response_count = response_count + 1 WHERE id = $1::bigint",
+      params = list(poll_id))
+    row <- DBI::dbGetQuery(conn,
+      "INSERT INTO poll_studio.responses (poll_id, choice_id, participant_code)
+       VALUES ($1::bigint, $2::bigint, $3) RETURNING id::text AS id",
+      params = list(poll_id, choice_id, code))
+    list(id = row$id[[1]], replayed = FALSE)
+  })
+}
+
+close_poll <- function(db, poll_id) {
+  poll_id <- identifier(poll_id)
+  pool::poolWithTransaction(db, function(conn) {
+    row <- DBI::dbGetQuery(conn,
+      "SELECT id FROM poll_studio.polls WHERE id = $1::bigint FOR UPDATE", params = list(poll_id))
+    if (nrow(row) == 0L) poll_error("Poll does not exist.", "missing")
+    DBI::dbExecute(conn,
+      "UPDATE poll_studio.polls SET closed_at = COALESCE(closed_at, clock_timestamp())
+       WHERE id = $1::bigint", params = list(poll_id))
+    invisible(TRUE)
+  })
+}

applications/poll-studio/R/validation.R

@@ -0,0 +1,56 @@
+poll_error <- function(message, kind = "validation") {
+  stop(structure(list(message = message, call = NULL),
+                 class = c(paste0("poll_", kind), "poll_error", "error", "condition")))
+}
+
+bounded_text <- function(value, maximum, field) {
+  if (!is.character(value) || length(value) != 1L || is.na(value) ||
+      grepl("[[:cntrl:]]", value)) {
+    poll_error(paste(field, "must be text without control characters."))
+  }
+  value <- trimws(value)
+  if (nchar(value, type = "chars") < 1L || nchar(value, type = "chars") > maximum) {
+    poll_error(paste(field, "is outside its length limit."))
+  }
+  value
+}
+
+validate_poll <- function(question, choices) {
+  question <- bounded_text(question, 200L, "Question")
+  if (!is.character(choices) || length(choices) < 2L || length(choices) > 8L) {
+    poll_error("Use two through eight choices.")
+  }
+  choices <- vapply(choices, bounded_text, character(1), maximum = 80L, field = "Choice")
+  if (anyDuplicated(choices)) poll_error("Choice labels must be distinct after trimming.")
+  list(question = question, choices = unname(choices))
+}
+
+identifier <- function(value) {
+  if (!is.character(value) || length(value) != 1L || is.na(value) ||
+      !grepl("^[1-9][0-9]{0,18}$", value) ||
+      (nchar(value) == 19L && value > "9223372036854775807")) {
+    poll_error("Choose a valid stored poll or choice.")
+  }
+  value
+}
+
+participant_code <- function(value) {
+  value <- toupper(bounded_text(value, 32L, "Participant code"))
+  if (!grepl("^[A-Z0-9][A-Z0-9_-]{2,31}$", value)) {
+    poll_error("Use a synthetic code of 3–32 letters, digits, underscores or hyphens.")
+  }
+  value
+}
+
+trusted_origin <- function(request, expected) {
+  origin <- request$HTTP_ORIGIN
+  is.character(origin) && length(origin) == 1L && !is.na(origin) && identical(origin, expected)
+}
+
+choice_lines <- function(value) {
+  if (!is.character(value) || length(value) != 1L || is.na(value) ||
+      nchar(value, type = "chars") > 1024L) {
+    poll_error("Choice input must be at most 1,024 characters.")
+  }
+  strsplit(value, "\n", fixed = TRUE)[[1]]
+}