inst/app/R/server_history.R

In dqcheckrGUI: Point-and-Click GUI Client for 'dqcheckr'

# History panel server logic (spec §18)

server_history <- function(input, output, session, rv, config_dir, gcfg_rv) {

  # Per-drift stdout logs are tempfile()s; track and remove them on session end
  # so they don't accumulate in tempdir() over a long-lived server process (B-11).
  .drift_logs <- new.env(parent = emptyenv())
  .drift_logs$paths <- character(0)
  session$onSessionEnded(function() unlink(.drift_logs$paths))

  hist_data  <- reactiveVal(data.frame())
  hist_limit <- reactiveVal(50L)

  # Load / reload history
  load_history <- function() {
    db_path <- resolve_infra_path(
      gcfg_rv()$snapshot_db, config_dir(),
      default = "data/snapshots.sqlite", mustWork = FALSE
    )
    df <- tryCatch(
      read_all_snapshot_history(db_path, n = hist_limit()),
      error = function(e) {
        d <- data.frame()
        attr(d, "db_error") <- conditionMessage(e)
        d
      })
    # A tagged read failure (corrupt/unreachable DB) must not masquerade as an
    # empty history — tell the user their data could not be read (B-10). The
    # tag rides along on the frame into the renderer, which picks the message.
    err <- attr(df, "db_error")
    if (!is.null(err))
      showNotification(paste("Could not read run history:", err),
                       type = "error", duration = 10)
    hist_data(df)
  }

  # Refresh when section activated or after a run
  observe({
    rv$active_section
    rv$history_refresh
    load_history()
  })

  observeEvent(input$history_load_more, {
    hist_limit(hist_limit() + 50L)
    load_history()
  })

  # Disclosure banner: the History table reads only the global snapshot DB, so a
  # dataset with a per-dataset snapshot_db override is silently absent (B-08).
  # Rather than merge across DBs (a behaviour change with its own edge cases),
  # surface the omission here so it is disclosed, not hidden. Recomputes when the
  # dataset list or global config changes. Dataset names are text children of the
  # tags below, so htmltools escapes them — no manual escaping needed.
  output$history_db_note <- renderUI({
    rv$active_section
    rv$dataset_refresh
    off <- datasets_off_global_history(config_dir(), gcfg_rv())
    if (length(off) == 0) return(NULL)
    n  <- length(off)
    is1 <- n == 1
    div(class = "alert alert-info py-2 px-3 mb-3", style = "font-size:13px;",
      tags$strong("Note: "),
      sprintf(
        "%d dataset%s use%s a separate snapshot database, so %s runs are not listed here: %s. Drift comparison for %s is unaffected.",
        n,
        if (is1) "" else "s",
        if (is1) "s" else "",
        if (is1) "its" else "their",
        paste(off, collapse = ", "),
        if (is1) "it" else "them"))
  })

  output$history_table <- DT::renderDataTable({
    df <- hist_data()
    if (nrow(df) == 0) {
      msg <- if (!is.null(attr(df, "db_error")))
        "Could not read run history — the snapshot database may be missing or corrupt."
      else
        "No run history found. Run a quality check first."
      return(DT::datatable(
        data.frame(Message = msg),
        options = list(dom = "t"), rownames = FALSE
      ))
    }

    # Build direct report links — avoids Shiny round-trip and popup blocking.
    # escape = FALSE below applies to ALL columns, so anything interpolated here
    # must be escaped by hand — file_name in particular is supplier-controlled.
    # Per-dataset URL prefix: datasets with a report_output_dir override are
    # served under their own resource path (see report_url_prefix()).
    cd   <- config_dir()
    gcfg <- gcfg_rv()
    prefixes <- vapply(unique(df$dataset_name), function(ds) {
      known <- read_dataset_known(cd, ds)
      report_url_prefix(ds, known$report_output_dir, cd, gcfg)
    }, character(1))
    row_prefix <- unname(prefixes[df$dataset_name])

    display_df <- data.frame(
      ` ` = sprintf(
        '<input type="checkbox" class="hist-check" data-id="%d" data-ds="%s" onchange="window.__dqHC(this)"/>',
        df$id, html_escape(df$dataset_name, attribute = TRUE)),
      Dataset = html_escape(df$dataset_name),
      Date    = utc_to_local_display(df$run_timestamp),
      File    = html_escape(df$file_name),
      Status  = vapply(df$overall_status, status_badge_html, character(1)),
      Fails   = df$check_fail_count,
      Rows    = df$row_count,
      # Same contract as the dataset panel: link only for a report that exists;
      # a 'pending' render shows "rendering…" (no dead link). See
      # report_link_cell() in utils.R. row_prefix/dataset_name are per-row here.
      Report  = report_link_cell(df$report_file, df$render_status,
                                 df$run_timestamp, df$dataset_name, row_prefix),
      stringsAsFactors = FALSE, check.names = FALSE
    )
    DT::datatable(display_df,
      escape    = FALSE, rownames = FALSE, selection = "none",
      filter    = "top",
      options   = list(pageLength = 50, scrollX = TRUE, dom = "ftip"),
      class     = "compact stripe hover"
    )
  })

  # Shared drift-launch helper
  launch_drift <- function(ds_name, id1, id2) {
    # rv_drift$proc is a single slot shared by both Compare buttons (History
    # panel and dataset panel). A second launch while one is in flight would
    # overwrite the handle, orphaning the first callr process so its completion
    # is never observed. Refuse the overlap instead (B-13/B-16); the poll
    # observer nulls the slot on completion, re-enabling Compare.
    if (!is.null(rv_drift$proc) && rv_drift$proc$is_alive()) {
      showNotification("A drift comparison is already running — please wait for it to finish.",
                       type = "warning", duration = 5)
      return(invisible(NULL))
    }
    cd         <- config_dir()
    # Resolve the snapshot DB for THIS dataset, honouring a per-dataset
    # snapshot_db override — the snapshot ids being compared are per-file
    # autoincrement integers that live in the dataset's own DB. Using the global
    # DB (as every other panel does not) would compare ids that either don't
    # exist there or belong to an unrelated dataset — a silent wrong-data drift
    # report (B-08). compare_snapshots() reads the dataset's own config for the
    # report dir, so only db_path needs resolving here.
    known      <- read_dataset_known(cd, ds_name)
    db_path    <- effective_db_path(cd, gcfg_rv(), known$snapshot_db)
    report_dir <- resolve_infra_path(gcfg_rv()$report_output_dir, cd,
                                     default = "reports/", mustWork = FALSE)
    prev_id    <- min(as.integer(c(id1, id2)))
    curr_id    <- max(as.integer(c(id1, id2)))
    showNotification("Starting drift comparison...", type = "message", duration = 4)
    drift_log           <- tempfile("dqcheckr_drift_", fileext = ".log")
    .drift_logs$paths   <- c(.drift_logs$paths, drift_log)   # unlinked on session end (B-11)
    rv_drift$proc       <- callr::r_bg(
      func = function(dn, p, c, db, cd) {
        dqcheckr::compare_snapshots(dn,
          snapshot_id_prev = p, snapshot_id_curr = c,
          db_path = db, config_dir = cd,
          report = TRUE, open_report = FALSE)
      },
      args    = list(dn = ds_name, p = prev_id, c = curr_id, db = db_path, cd = cd),
      stdout  = drift_log,
      stderr  = "2>&1",
      # Run in the deployment root so dqcheckr resolves any relative paths the
      # same way the CLI does (shiny::runApp has changed this process's getwd()).
      wd      = deployment_root(cd),
      package = TRUE
    )
    rv_drift$log_path   <- drift_log
    rv_drift$report_dir <- report_dir
    rv_drift$ds_name    <- ds_name
  }

  # Compare drift — async, non-blocking
  rv_drift <- reactiveValues(proc = NULL, report_dir = NULL, ds_name = NULL, log_path = NULL)

  observeEvent(input$history_compare, {
    ids <- input$hist_selected_ids
    req(length(ids) == 2)
    df   <- hist_data()
    row1 <- df[df$id == as.integer(ids[1]), ]
    req(nrow(row1) > 0)
    launch_drift(row1$dataset_name[1], ids[1], ids[2])
  })

  # Drift request from dataset panel compare button
  observeEvent(rv$drift_request, {
    req(!is.null(rv$drift_request))
    req(length(rv$drift_request$ids) == 2)
    launch_drift(rv$drift_request$ds, rv$drift_request$ids[1], rv$drift_request$ids[2])
  })

  # Poll for drift completion — 500ms intervals, non-blocking
  observe({
    req(!is.null(rv_drift$proc))
    invalidateLater(500)
    proc <- rv_drift$proc
    if (is.null(proc) || proc$is_alive()) return()

    result <- tryCatch(proc$get_result(), error = function(e) {
      last_line <- tail_nonblank_log_line(rv_drift$log_path)
      msg <- if (nchar(last_line) > 0) last_line else conditionMessage(e)
      showNotification(paste("Drift comparison failed:", msg),
                       type = "error", duration = 10)
      NULL
    })
    rv_drift$proc <- NULL
    if (is.null(result)) return()

    # dqcheckr (>= 0.2.5) returns the rendered report's path directly; link to
    # it rather than re-deriving the filename with a slug regex (which broke when
    # the drift filename gained its snapshot ids). NULL means no report was
    # written (e.g. Quarto unavailable) -- the drift still ran.
    # Build the link with the target dataset's own report URL prefix — a
    # per-dataset report_output_dir is served under dq_reports_<ds> (B-09).
    drift_ds     <- rv_drift$ds_name
    drift_prefix <- report_url_prefix(
      drift_ds, read_dataset_known(config_dir(), drift_ds)$report_output_dir,
      config_dir(), gcfg_rv())
    url <- drift_report_url(result, drift_prefix)
    if (!is.null(url)) {
      showModal(modalDialog(
        title  = "Drift comparison complete",
        tags$a(href = url, target = "_blank", class = "btn btn-primary",
               "Open drift report ↗"),
        footer = modalButton("Close"),
        easyClose = TRUE
      ))
    } else {
      showNotification(
        "Drift comparison complete, but no HTML report was written (Quarto may be unavailable).",
        type = "warning"
      )
    }
  })
}