1 2globalVariables("private") 3 4#' testthat reporter that checks if child processes are cleaned up in tests 5#' 6#' `CleanupReporter` takes an existing testthat `Reporter` object, and 7#' wraps it, so it checks for leftover child processes, at the specified 8#' place, see the `proc_unit` argument below. 9#' 10#' Child processes can be reported via a failed expectation, cleaned up 11#' silently, or cleaned up and reported (the default). 12#' 13#' The constructor of the `CleanupReporter` class has options: 14#' * `file`: the output file, if any, this is passed to `reporter`. 15#' * `proc_unit`: when to perform the child process check and cleanup. 16#' Possible values: 17#' * `"test"`: at the end of each [testthat::test_that()] block 18#' (the default), 19#' * `"testsuite"`: at the end of the test suite. 20#' * `proc_cleanup`: Logical scalar, whether to kill the leftover 21#' processes, `TRUE` by default. 22#' * `proc_fail`: Whether to create an expectation, that fails if there 23#' are any processes alive, `TRUE` by default. 24#' * `proc_timeout`: How long to wait for the processes to quit. This is 25#' sometimes needed, because even if some kill signals were sent to 26#' child processes, it might take a short time for these to take effect. 27#' It defaults to one second. 28#' * `rconn_unit`: When to perform the R connection cleanup. Possible values 29#' are `"test"` and `"testsuite"`, like for `proc_unit`. 30#' * `rconn_cleanup`: Logical scalar, whether to clean up leftover R 31#' connections. `TRUE` by default. 32#' * `rconn_fail`: Whether to fail for leftover R connections. `TRUE` by 33#' default. 34#' * `file_unit`: When to check for open files. Possible values are 35#' `"test"` and `"testsuite"`, like for `proc_unit`. 36#' * `file_fail`: Whether to fail for leftover open files. `TRUE` by 37#' default. 38#' * `conn_unit`: When to check for open network connections. 39#' Possible values are `"test"` and `"testsuite"`, like for `proc_unit`. 40#' * `conn_fail`: Whether to fail for leftover network connections. 41#' `TRUE` by default. 42#' 43#' @note Some IDEs, like RStudio, start child processes frequently, and 44#' sometimes crash when these are killed, only use this reporter in a 45#' terminal session. In particular, you can always use it in the 46#' idiomatic `testthat.R` file, that calls `test_check()` during 47#' `R CMD check`. 48#' 49#' @param reporter A testthat reporter to wrap into a new `CleanupReporter` 50#' class. 51#' @return New reporter class that behaves exactly like `reporter`, 52#' but it checks for, and optionally cleans up child processes, at the 53#' specified granularity. 54#' 55#' @section Examples: 56#' This is how to use this reporter in `testthat.R`: 57#' ``` 58#' library(testthat) 59#' library(mypackage) 60#' 61#' if (ps::ps_is_supported()) { 62#' reporter <- ps::CleanupReporter(testthat::ProgressReporter)$new( 63#' proc_unit = "test", proc_cleanup = TRUE) 64#' } else { 65#' ## ps does not support this platform 66#' reporter <- "progress" 67#' } 68#' 69#' test_check("mypackage", reporter = reporter) 70#' ``` 71#' 72#' @export 73 74CleanupReporter <- function(reporter = testthat::ProgressReporter) { 75 76 R6::R6Class("CleanupReporter", 77 inherit = reporter, 78 public = list( 79 80 initialize = function( 81 file = getOption("testthat.output_file", stdout()), 82 proc_unit = c("test", "testsuite"), 83 proc_cleanup = TRUE, proc_fail = TRUE, proc_timeout = 1000, 84 rconn_unit = c("test", "testsuite"), 85 rconn_cleanup = TRUE, rconn_fail = TRUE, 86 file_unit = c("test", "testsuite"), file_fail = TRUE, 87 conn_unit = c("test", "testsuite"), conn_fail = TRUE) { 88 89 if (!ps::ps_is_supported()) { 90 stop("CleanupReporter is not supported on this platform") 91 } 92 93 super$initialize(file = file) 94 private$proc_unit <- match.arg(proc_unit) 95 private$proc_cleanup <- proc_cleanup 96 private$proc_fail <- proc_fail 97 private$proc_timeout <- proc_timeout 98 99 private$rconn_unit <- match.arg(rconn_unit) 100 private$rconn_cleanup <- rconn_cleanup 101 private$rconn_fail <- rconn_fail 102 103 private$file_unit <- match.arg(file_unit) 104 private$file_fail <- file_fail 105 106 private$conn_unit <- match.arg(conn_unit) 107 private$conn_fail <- conn_fail 108 109 invisible(self) 110 }, 111 112 start_test = function(context, test) { 113 super$start_test(context, test) 114 if (private$file_unit == "test") private$files <- ps_open_files(ps_handle()) 115 if (private$rconn_unit == "test") private$rconns <- showConnections() 116 if (private$proc_unit == "test") private$tree_id <- ps::ps_mark_tree() 117 if (private$conn_unit == "test") private$conns <- ps_connections(ps_handle()) 118 }, 119 120 end_test = function(context, test) { 121 if (private$proc_unit == "test") self$do_proc_cleanup(test) 122 if (private$rconn_unit == "test") self$do_rconn_cleanup(test) 123 if (private$file_unit == "test") self$do_file_cleanup(test) 124 if (private$conn_unit == "test") self$do_conn_cleanup(test) 125 super$end_test(context, test) 126 }, 127 128 start_reporter = function() { 129 super$start_reporter() 130 if (private$file_unit == "testsuite") private$files <- ps_open_files(ps_handle()) 131 if (private$rconn_unit == "testsuite") private$rconns <- showConnections() 132 if (private$proc_unit == "testsuite") private$tree_id <- ps::ps_mark_tree() 133 if (private$conn_unit == "testsuite") private$conns <- ps_connections(ps_handle()) 134 }, 135 136 end_reporter = function() { 137 super$end_reporter() 138 if (private$proc_unit == "testsuite") { 139 self$do_proc_cleanup("testsuite", quote = "") 140 } 141 if (private$rconn_unit == "testsuite") { 142 self$do_rconn_cleanup("testsuite", quote = "") 143 } 144 if (private$file_unit == "testsuite") { 145 self$do_file_cleanup("testsuite", quote = "") 146 } 147 if (private$conn_unit == "testsuite") { 148 self$do_conn_cleanup("testsuite", quote = "") 149 } 150 }, 151 152 do_proc_cleanup = function(test, quote = "'") { 153 Sys.unsetenv(private$tree_id) 154 deadline <- Sys.time() + private$proc_timeout / 1000 155 if (private$proc_fail) { 156 while (length(ret <- ps::ps_find_tree(private$tree_id)) && 157 Sys.time() < deadline) Sys.sleep(0.05) 158 } 159 if (private$proc_cleanup) { 160 ret <- ps::ps_kill_tree(private$tree_id) 161 } 162 if (private$proc_fail) { 163 testthat::with_reporter(self, start_end_reporter = FALSE, { 164 self$expect_cleanup(test, ret, quote) 165 }) 166 } 167 }, 168 169 do_rconn_cleanup = function(test, quote = "'") { 170 old <- private$rconns 171 new <- showConnections() 172 private$rconns <- NULL 173 leftover <- ! new[, "description"] %in% old[, "description"] 174 175 if (private$rconn_cleanup) { 176 for (no in as.integer(rownames(new)[leftover])) { 177 tryCatch(close(getConnection(no)), error = function(e) NULL) 178 } 179 } 180 181 if (private$rconn_fail) { 182 act <- testthat::quasi_label(rlang::enquo(test), test) 183 testthat::expect( 184 sum(leftover) == 0, 185 sprintf( 186 "%s did not close R connections: %s", 187 encodeString(act$lab, quote = quote), 188 paste0(encodeString(new[leftover, "description"], quote = "'"), 189 " (", rownames(new)[leftover], ")", collapse = ", "))) 190 } 191 }, 192 193 do_file_cleanup = function(test, quote = "'") { 194 old <- private$files 195 new <- ps_open_files(ps_handle()) 196 private$files <- NULL 197 leftover <- ! new$path %in% old$path 198 199 ## Need to ignore some open files: 200 ## * /dev/urandom might be opened internally by curl, openssl, etc. 201 leftover <- leftover & new$path != "/dev/urandom" 202 203 if (private$file_fail) { 204 act <- testthat::quasi_label(rlang::enquo(test), test) 205 testthat::expect( 206 sum(leftover) == 0, 207 sprintf( 208 "%s did not close open files: %s", 209 encodeString(act$lab, quote = quote), 210 paste0(encodeString(new$path[leftover], quote = "'"), 211 collapse = ", "))) 212 } 213 }, 214 215 do_conn_cleanup = function(test, quote = "'") { 216 old <- private$conns[, 1:6] 217 private$conns <- NULL 218 219 ## On windows, sometimes it takes time to remove the connection 220 ## from the processes connection tables, so we try waiting a bit. 221 ## We haven't seen issues with this on other OSes yet. 222 deadline <- Sys.time() + as.difftime(0.5, units = "secs") 223 repeat { 224 new <- ps_connections(ps_handle())[, 1:6] 225 ## This is a connection that is used internally on macOS, 226 ## for DNS resolution. We'll just ignore it. Looks like this: 227 ## # A tibble: 2 x 6 228 ## fd family type laddr lport raddr 229 ## <int> <chr> <chr> <chr> <int> <chr> 230 ## 7 AF_UNIX SOCK_STREAM <NA> NA /var/run/mDNSResponder 231 ## 10 AF_UNIX SOCK_STREAM <NA> NA /var/run/mDNSResponder 232 new <- new[ 233 new$family != "AF_UNIX" | 234 new$type != "SOCK_STREAM" | 235 is.na(new$raddr) | 236 paste(tolower(basename(new$raddr))) != "mdnsresponder", ] 237 238 leftover <- ! apply(new, 1, paste, collapse = "&") %in% 239 apply(old, 1, paste, collapse = "&") 240 241 if (!ps_os_type()[["WINDOWS"]] || 242 sum(leftover) == 0 || 243 Sys.time() >= deadline) break; 244 245 Sys.sleep(0.05) 246 } 247 248 if (private$conn_fail) { 249 left <- new[leftover,] 250 act <- testthat::quasi_label(rlang::enquo(test), test) 251 testthat::expect( 252 sum(leftover) == 0, 253 sprintf( 254 "%s did not close network connections: \n%s", 255 encodeString(act$lab, quote = quote), 256 paste(format(left), collapse = "\n"))) 257 } 258 }, 259 260 expect_cleanup = function(test, pids, quote) { 261 act <- testthat::quasi_label(rlang::enquo(test), test) 262 act$pids <- length(pids) 263 testthat::expect( 264 length(pids) == 0, 265 sprintf("%s did not clean up processes: %s", 266 encodeString(act$lab, quote = quote), 267 paste0(encodeString(names(pids), quote = "'"), 268 " (", pids, ")", collapse = ", "))) 269 270 invisible(act$val) 271 } 272 ), 273 274 private = list( 275 proc_unit = NULL, 276 proc_cleanup = NULL, 277 proc_fail = NULL, 278 proc_timeout = NULL, 279 280 rconn_unit = NULL, 281 rconn_cleanup = NULL, 282 rconn_fail = NULL, 283 rconns = NULL, 284 285 file_unit = NULL, 286 file_fail = NULL, 287 files = NULL, 288 289 conn_unit = NULL, 290 conn_fail = NULL, 291 conns = NULL, 292 293 tree_id = NULL 294 ) 295 ) 296} 297