fix: constrain interactive binary choices to 1 or 2

.jules/sentinel.md

@@ -2,3 +2,8 @@
 **Vulnerability:** Unvalidated inputs passed to `if()` statements can cause process crashes (`condition has length > 1`) or unexpected coercion vulnerabilities.
 **Learning:** In R, optional boolean parameters that default to `NULL` should be validated using explicit runtime type validation (e.g., `if (!is.null(flag) && (!is.logical(flag) || length(flag) != 1 || is.na(flag)))`).
 **Prevention:** Always implement explicit runtime type validation for optional boolean parameters.
+
+## 2026-09-13 - 대화형 이진 선택 입력을 실제 허용 집합으로 제한
+**Finding:** 세 대화형 프롬프트가 `1`과 `2`만 의미 있게 사용하면서도 모든 숫자 문자열을 먼저 허용했습니다. 매우 큰 숫자는 `as.integer()`에서 `NA`가 되어 제어 흐름 오류를 만들 수 있고, `0`이나 `3`도 의미 없는 값으로 후속 분기에 들어갈 수 있었습니다.
+**Learning:** 선택형 입력은 숫자 여부를 넓게 확인한 뒤 변환하기보다 실제 도메인 허용값을 그대로 검증해야 합니다. 이 경로는 로컬 대화형 입력이므로 별도의 원격 신뢰 경계가 입증되지 않은 상태에서 보안 심각도를 부여하지 않습니다.
+**Prevention:** 공통 문항 확인과 old/new-form BILOG prior 프롬프트 모두 문자열 `"1"` 또는 `"2"`만 정확히 허용하고, 그 밖의 값은 제한된 재시도 뒤 통제된 오류로 종료합니다.

R/aFIPC.R

@@ -141,7 +141,7 @@ autoFIPC <-
       }
       for (attempt in seq_len(3)) {
         n <- readline(prompt = "Is it correct? (1: Yes 2: No) : ")
-        if (grepl("^[0-9]+$", n)) {
+        if (n %in% c("1", "2")) {
           return(as.integer(n))
         }
       }
@@ -171,7 +171,7 @@ autoFIPC <-
               readline(
                 prompt = "Do you want to use default BILOG-MG priors for oldform Data? (1: Yes 2: No) : "
               )
-            if (grepl("^[0-9]+$", n)) {
+            if (n %in% c("1", "2")) {
               return(as.integer(n))
             }
           }
@@ -390,7 +390,7 @@ autoFIPC <-
               readline(
                 prompt = "Do you want to use default BILOG-MG priors for newform Data? (1: Yes 2: No) : "
               )
-            if (grepl("^[0-9]+$", n)) {
+            if (n %in% c("1", "2")) {
               return(as.integer(n))
             }
           }

tests/testthat/test-interactive-binary-choice.R

@@ -0,0 +1,278 @@
+scripted_auto_fipc <- function(values) {
+  index <- 0L
+  fn <- aFIPC::autoFIPC
+  test_env <- new.env(parent = environment(fn))
+  test_env$interactive <- function() TRUE
+  test_env$readline <- function(prompt = "") {
+    index <<- index + 1L
+    values[[min(index, length(values))]]
+  }
+  environment(fn) <- test_env
+
+  list(
+    run = fn,
+    reads = function() index
+  )
+}
+
+find_nested_function_expression <- function(expression, function_name) {
+  if (!is.call(expression)) {
+    return(NULL)
+  }
+
+  if (
+    length(expression) >= 3L &&
+      identical(expression[[1L]], as.name("<-")) &&
+      identical(expression[[2L]], as.name(function_name)) &&
+      is.call(expression[[3L]]) &&
+      identical(expression[[3L]][[1L]], as.name("function"))
+  ) {
+    return(expression[[3L]])
+  }
+
+  for (part in as.list(expression)[-1L]) {
+    nested <- find_nested_function_expression(part, function_name)
+    if (!is.null(nested)) {
+      return(nested)
+    }
+  }
+
+  NULL
+}
+
+find_prior_assignment_block <- function(expression, function_name, target_name) {
+  if (!is.call(expression)) {
+    return(NULL)
+  }
+
+  if (identical(expression[[1L]], as.name("if")) && length(expression) >= 3L) {
+    body_expr <- expression[[3L]]
+
+    if (is.call(body_expr) && identical(body_expr[[1L]], as.name("{"))) {
+        for (i in seq_len(length(body_expr))) {
+            stmt <- body_expr[[i]]
+            if (is.call(stmt) && identical(stmt[[1L]], as.name("<-")) && identical(stmt[[2L]], as.name(target_name))) {
+                if (is.call(stmt[[3L]]) && identical(stmt[[3L]][[1L]], as.name(function_name))) {
+                    new_block <- substitute({
+                        check_fn <- function() {}
+                        target <- check_fn()
+                    }, list(target = as.name(target_name), check_fn = as.name(function_name)))
+
+                    for (j in seq_len(length(body_expr))) {
+                        if (is.call(body_expr[[j]]) && identical(body_expr[[j]][[1L]], as.name("<-")) && identical(body_expr[[j]][[2L]], as.name(function_name))) {
+                            new_block[[2L]] <- body_expr[[j]]
+                        }
+                        if (is.call(body_expr[[j]]) && identical(body_expr[[j]][[1L]], as.name("<-")) && identical(body_expr[[j]][[2L]], as.name(target_name))) {
+                            new_block[[3L]] <- body_expr[[j]]
+                        }
+                        if (is.call(body_expr[[j]]) && identical(body_expr[[j]][[1L]], as.name("if")) && is.call(body_expr[[j]][[2L]]) && identical(body_expr[[j]][[2L]][[2L]], as.name(target_name))) {
+                            if_block <- body_expr[[j]]
+                            new_block[[4L]] <- substitute(if (!is.null(target)) if_block, list(target=as.name(target_name), if_block=if_block))
+                        }
+                    }
+
+                    return(new_block)
+                }
+            }
+        }
+    }
+  }
+
+  for (part in as.list(expression)[-1L]) {
+    nested <- find_prior_assignment_block(part, function_name, target_name)
+    if (!is.null(nested)) {
+      return(nested)
+    }
+  }
+
+  NULL
+}
+
+scripted_nested_prompt <- function(function_name, values, confirm_common_items = NULL) {
+  function_expression <- find_nested_function_expression(
+    body(aFIPC::autoFIPC),
+    function_name
+  )
+  if (is.null(function_expression)) {
+    stop(sprintf("Could not find nested prompt helper %s", function_name))
+  }
+
+  index <- 0L
+  test_env <- new.env(parent = environment(aFIPC::autoFIPC))
+  test_env$confirmCommonItems <- confirm_common_items
+  test_env$interactive <- function() TRUE
+  test_env$readline <- function(prompt = "") {
+    index <<- index + 1L
+    values[[min(index, length(values))]]
+  }
+
+  list(
+    run = eval(function_expression, envir = test_env),
+    reads = function() index
+  )
+}
+
+scripted_prior_assignment <- function(function_name, target_name, value) {
+  assignment_block <- find_prior_assignment_block(
+    body(aFIPC::autoFIPC),
+    function_name,
+    target_name
+  )
+  if (is.null(assignment_block)) {
+    stop(sprintf("Could not find assignment block for %s", function_name))
+  }
+
+  index <- 0L
+  test_env <- new.env(parent = environment(aFIPC::autoFIPC))
+  test_env$itemtype <- "3PL"
+  test_env[[target_name]] <- NULL
+  test_env$interactive <- function() TRUE
+  test_env$readline <- function(prompt = "") {
+    index <<- index + 1L
+    value
+  }
+
+  eval(assignment_block, envir = test_env)
+
+  list(
+    value = test_env[[target_name]],
+    reads = index
+  )
+}
+
+test_that("common-item confirmation rejects coercible and overflow choices", {
+  huge_integer <- paste(rep("9", 1000), collapse = "")
+  runner <- scripted_auto_fipc(c("3", " 1", huge_integer))
+
+  expect_error(
+    runner$run(
+      newformXData = data.frame(A = c(0, 1)),
+      oldformYData = data.frame(A = c(0, 1)),
+      newformCommonItemNames = "A",
+      oldformCommonItemNames = "A"
+    ),
+    "Too many invalid common item confirmation attempts",
+    fixed = TRUE
+  )
+  expect_identical(runner$reads(), 3L)
+})
+
+test_that("common-item exact choices drive reject or proceed behavior", {
+  reject_runner <- scripted_auto_fipc("2")
+  expect_error(
+    reject_runner$run(
+      newformXData = data.frame(A = c(0, 1)),
+      oldformYData = data.frame(A = c(0, 1)),
+      newformCommonItemNames = "A",
+      oldformCommonItemNames = "A"
+    ),
+    "Please write down pairs correctly",
+    fixed = TRUE
+  )
+  expect_identical(reject_runner$reads(), 1L)
+
+  huge_integer <- paste(rep("9", 1000), collapse = "")
+  proceed_runner <- scripted_auto_fipc(c("1", "0", "+1", huge_integer))
+  expect_error(
+    proceed_runner$run(
+      newformXData = data.frame(A = c(0, 1)),
+      oldformYData = data.frame(A = c(0, 1)),
+      newformCommonItemNames = "A",
+      oldformCommonItemNames = "A"
+    ),
+    "Too many invalid oldform BILOG prior attempts",
+    fixed = TRUE
+  )
+  expect_identical(proceed_runner$reads(), 4L)
+})
+
+test_that("old-form prior prompt uses the same exact binary-choice contract", {
+  huge_integer <- paste(rep("9", 1000), collapse = "")
+  runner <- scripted_auto_fipc(c("0", "+1", huge_integer))
+
+  expect_error(
+    runner$run(
+      newformXData = data.frame(A = c(0, 1)),
+      oldformYData = data.frame(A = c(0, 1)),
+      newformCommonItemNames = "A",
+      oldformCommonItemNames = "A",
+      confirmCommonItems = TRUE
+    ),
+    "Too many invalid oldform BILOG prior attempts",
+    fixed = TRUE
+  )
+  expect_identical(runner$reads(), 3L)
+})
+
+test_that("all three prompt helpers accept only the exact binary choices", {
+  helper_names <- c(
+    "checkCorrect",
+    "checkoldformBILOGprior",
+    "checknewformBILOGprior"
+  )
+
+  for (helper_name in helper_names) {
+    yes_runner <- scripted_nested_prompt(helper_name, "1")
+    expect_identical(
+      yes_runner$run(),
+      1L,
+      info = sprintf("%s should accept exact choice 1", helper_name)
+    )
+    expect_identical(yes_runner$reads(), 1L)
+
+    no_runner <- scripted_nested_prompt(helper_name, "2")
+    expect_identical(
+      no_runner$run(),
+      2L,
+      info = sprintf("%s should accept exact choice 2", helper_name)
+    )
+    expect_identical(no_runner$reads(), 1L)
+  }
+})
+
+test_that("old-form and new-form choices set their logical prior flags", {
+  old_yes <- scripted_prior_assignment(
+    "checkoldformBILOGprior",
+    "oldformBILOGprior",
+    "1"
+  )
+  old_no <- scripted_prior_assignment(
+    "checkoldformBILOGprior",
+    "oldformBILOGprior",
+    "2"
+  )
+  new_yes <- scripted_prior_assignment(
+    "checknewformBILOGprior",
+    "newformBILOGprior",
+    "1"
+  )
+  new_no <- scripted_prior_assignment(
+    "checknewformBILOGprior",
+    "newformBILOGprior",
+    "2"
+  )
+
+  expect_identical(old_yes$value, TRUE)
+  expect_identical(old_no$value, FALSE)
+  expect_identical(new_yes$value, TRUE)
+  expect_identical(new_no$value, FALSE)
+  expect_identical(old_yes$reads, 1L)
+  expect_identical(old_no$reads, 1L)
+  expect_identical(new_yes$reads, 1L)
+  expect_identical(new_no$reads, 1L)
+})
+
+test_that("new-form prior prompt rejects representative invalid choices", {
+  huge_integer <- paste(rep("9", 1000), collapse = "")
+  runner <- scripted_nested_prompt(
+    "checknewformBILOGprior",
+    c("0", " 2", huge_integer)
+  )
+
+  expect_error(
+    runner$run(),
+    "Too many invalid newform BILOG prior attempts",
+    fixed = TRUE
+  )
+  expect_identical(runner$reads(), 3L)
+})