Validate public arguments before model evaluation

.jules/sentinel.md

@@ -12,3 +12,7 @@
 **Vulnerability:** Raw `stop()` and `warning()` calls without `call. = FALSE` in `llcont.R` and `vuongtest.R` exposed execution stack/call details when raised.
 **Learning:** While some instances of `stop()` inside `tryCatch()` were previously fixed to hide the call stack, other standalone exceptions and warnings still leaked call context. Security must be consistently applied across the entire codebase.
 **Prevention:** Always set `call. = FALSE` when using `stop()` or `warning()` to enforce a secure-by-default boundary and prevent internal execution paths from being disclosed to the end user.
+## 2024-09-03 - [Input Validation and Secure Failures]
+**Vulnerability:** Unvalidated inputs passed to exported functions can bypass top-level `stop()` safeguards, triggering raw errors deep inside internal execution contexts and exposing internal states.
+**Learning:** In R, evaluating malformed parameters (like NAs or missing logicals) inside `if` statements can crash the application or leak system state (e.g., "missing value where TRUE/FALSE needed").
+**Prevention:** Always place strict type, length, and `is.na()` checks at the absolute beginning of exported functions, using `||` for safe short-circuiting, to fail securely and deliberately.

NEWS

@@ -2,6 +2,9 @@ Changes in Version 0.5-9
 
     o bug fixes: lavaan parameter counts with equality constraints, mirt DiscreteClass (credit to Seongho Bae)
 
+    o validate public vuongtest() and icci() arguments before model evaluation,
+      with stable errors for invalid nested/adj/conf.level values and callbacks
+
 Changes in Version 0.5-8
 
     o add support for objects of DiscreteClass from mirt package (credit to Phil Chalmers)

R/icci.R

@@ -65,6 +65,13 @@
 #' @export
 icci <- function(object1, object2, conf.level=.95, ll1=llcont, ll2=llcont) {
 
+  if (length(conf.level) != 1 || is.na(conf.level) || !is.numeric(conf.level) || conf.level <= 0 || conf.level >= 1) {
+    stop("conf.level must be a single numeric value strictly between 0 and 1", call. = FALSE)
+  }
+  if (!is.function(ll1) || !is.function(ll2)) {
+    stop("ll1 and ll2 must be functions", call. = FALSE)
+  }
+
   ## check objects, issue warnings/errors, get classes/calls
   obinfo <- check.obj(object1, object2)
   callA <- obinfo$callA; classA <- obinfo$classA

R/vuongtest.R

@@ -98,6 +98,22 @@
 #' @export
 vuongtest <- function(object1, object2, nested=FALSE, adj="none", ll1=llcont, ll2=llcont, score1=NULL, score2=NULL, vc1=vcov, vc2=vcov) {
 
+  if (length(nested) != 1 || is.na(nested) || !is.logical(nested)) {
+    stop("nested must be a single logical value", call. = FALSE)
+  }
+  if (length(adj) != 1 || is.na(adj) || !is.character(adj) || !(adj %in% c("none", "aic", "bic"))) {
+    stop('adj must be one of "none", "aic", or "bic"', call. = FALSE)
+  }
+  if (!is.function(ll1) || !is.function(ll2)) {
+    stop("ll1 and ll2 must be functions", call. = FALSE)
+  }
+  if ((!is.null(score1) && !is.function(score1)) || (!is.null(score2) && !is.function(score2))) {
+    stop("score1 and score2 must be functions or NULL", call. = FALSE)
+  }
+  if (!is.function(vc1) || !is.function(vc2)) {
+    stop("vc1 and vc2 must be functions", call. = FALSE)
+  }
+
   ## check objects, issue warnings/errors, get classes/calls
   obinfo <- check.obj(object1, object2)
   callA <- obinfo$callA; classA <- obinfo$classA

tests/testthat/test_public_argument_validation.R

@@ -0,0 +1,45 @@
+test_that("vuongtest rejects malformed public arguments before object inspection", {
+  invalid_cases <- list(
+    list(args = list(nested = NA), message = "nested must be a single logical value"),
+    list(args = list(nested = c(TRUE, FALSE)), message = "nested must be a single logical value"),
+    list(args = list(adj = NA_character_), message = 'adj must be one of "none", "aic", or "bic"'),
+    list(args = list(adj = "unknown"), message = 'adj must be one of "none", "aic", or "bic"'),
+    list(args = list(ll1 = "llcont"), message = "ll1 and ll2 must be functions"),
+    list(args = list(score1 = "score"), message = "score1 and score2 must be functions or NULL"),
+    list(args = list(vc1 = "vcov"), message = "vc1 and vc2 must be functions")
+  )
+
+  for (case in invalid_cases) {
+    err <- tryCatch(
+      do.call(vuongtest, c(list(object1 = NULL, object2 = NULL), case$args)),
+      error = identity
+    )
+
+    expect_s3_class(err, "error")
+    expect_identical(conditionMessage(err), case$message)
+    expect_null(conditionCall(err))
+  }
+})
+
+
+test_that("icci rejects malformed public arguments before object inspection", {
+  invalid_cases <- list(
+    list(args = list(conf.level = NA_real_), message = "conf.level must be a single numeric value strictly between 0 and 1"),
+    list(args = list(conf.level = c(0.9, 0.95)), message = "conf.level must be a single numeric value strictly between 0 and 1"),
+    list(args = list(conf.level = 0), message = "conf.level must be a single numeric value strictly between 0 and 1"),
+    list(args = list(conf.level = 1), message = "conf.level must be a single numeric value strictly between 0 and 1"),
+    list(args = list(conf.level = "0.95"), message = "conf.level must be a single numeric value strictly between 0 and 1"),
+    list(args = list(ll2 = "llcont"), message = "ll1 and ll2 must be functions")
+  )
+
+  for (case in invalid_cases) {
+    err <- tryCatch(
+      do.call(icci, c(list(object1 = NULL, object2 = NULL), case$args)),
+      error = identity
+    )
+
+    expect_s3_class(err, "error")
+    expect_identical(conditionMessage(err), case$message)
+    expect_null(conditionCall(err))
+  }
+})