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