Fix ever-growing call stacks

- Re-entering domains was happening additively, instead of
  replacing the active domain as it should've been doing.
- Wrapping for re-entering wasn't happening if the domain
  at the time of binding was NULL. This was incorrect! If
  the domain was NULL at binding time, and non-NULL at
  the time of resolution, then the domain needs to be set
  back to NULL before the handler is invoked!
- Fixed the cpp test that had the wrong value all along
- Added more tests to catch regressions in this area

NEWS.md

@@ -1,3 +1,8 @@
+# promises (under development)
+
+* Fixed bug introduced in 1.3.1, where promise domains that are active at promise resolution time stay active during handler callback, even if they weren't active when the handler was registered. This was causing stack overflow for long promise chains with many active promise domains.
+
+
 # promises 1.3.1
 
 * Fixed bug where promise domains were forgotten when handlers were registered from within other handlers. (#110)

R/domains.R

@@ -72,19 +72,20 @@ promiseDomain <- list(
       onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected
     )
     results <- results[!vapply(results, is.null, logical(1))]
-    if (!is.null(domain)) {
-      # If there's a domain, ensure that before any callback is invoked, we
-      # reenter the domain. This is important for this kind of code:
-      #
-      #     with_promise_domain(domain, {
-      #       async_sleep(0.1) %...>% {
-      #         async_sleep(0.1) %...>% {
-      #           # Without re-entry, this would be outside the domain!
-      #         }
-      #       }
-      #     })
-      results <- lapply(results, wrap_callback_reenter, domain = domain)
-    }
+    # If there's a domain, ensure that before any callback is invoked, we
+    # reenter the domain. This is important for this kind of code:
+    #
+    #     with_promise_domain(domain, {
+    #       async_sleep(0.1) %...>% {
+    #         async_sleep(0.1) %...>% {
+    #           # Without re-entry, this would be outside the domain!
+    #         }
+    #       }
+    #     })
+    #
+    # It's important to reenter even if domain is NULL. In that case, we need to
+    # ensure that the current domain is set to NULL while the callback executes.
+    results <- lapply(results, wrap_callback_reenter, domain = domain)
     results
   },
   onError = function(error) {
@@ -100,7 +101,10 @@ wrap_callback_reenter <- function(callback, domain) {
   force(domain)
 
   wrapper <- function(...) {
-    reenter_promise_domain(domain, callback(...))
+    # replace = TRUE because we don't care what the current domain is; we're
+    # (temporarily) putting the world back to the way it was when the callback
+    # was bound to a promise.
+    reenter_promise_domain(domain, callback(...), replace = TRUE)
   }
 
   # There are parts of this package that will inspect formals() to see if
@@ -171,7 +175,7 @@ with_promise_domain <- function(domain, expr, replace = FALSE) {
 }
 
 # Like with_promise_domain, but doesn't include the wrapSync call.
-reenter_promise_domain <- function(domain, expr, replace = FALSE) {
+reenter_promise_domain <- function(domain, expr, replace) {
   oldval <- current_promise_domain()
   if (replace)
     globals$domain <- domain

tests/testthat/test-cpp.R

@@ -17,9 +17,10 @@ describe("C++ interface", {
       }) %...>%
         {
           expect_identical(., 2)
+          expect_identical(cd$counts$onFulfilledCalled, 1L)
           promise_resolve(TRUE) %...>% {
             expect_true(!is.null(current_promise_domain()))
-            expect_identical(cd$counts$onFulfilledCalled, 3L)
+            expect_identical(cd$counts$onFulfilledCalled, 2L)
           }
         } %>%
         wait_for_it()

tests/testthat/test-domains.R

@@ -169,4 +169,48 @@ describe("Promise domains", {
     expect_identical(x, 2L)
 
   })
+
+  it("doesn't grow the call stack", {
+    # See https://github.com/rstudio/promises/issues/114
+    # and also https://github.com/jcheng5/shinychat/issues/16
+
+    recursive_promise <- function(n, .last_callstack_depth = NULL) {
+      if (n == 0) {
+        return(0)
+      } else {
+        promise_resolve(TRUE) %...>% {
+          current_callstack_depth <- length(sys.calls())
+          if (!is.null(.last_callstack_depth)) {
+            expect_identical(current_callstack_depth, .last_callstack_depth)
+          }
+
+          recursive_promise(n - 1, .last_callstack_depth = current_callstack_depth)
+        }
+      }
+    }
+
+    cd <- create_counting_domain()
+    with_promise_domain(cd, {
+      recursive_promise(5) %...>%
+        {
+          # 5 (from inside recursive_promise) + 1 (for the current handler)
+          expect_identical(cd$counts$onFulfilledCalled, 6L)
+        } %>%
+        wait_for_it()
+    })
+
+    cd2 <- create_counting_domain()
+    p <- recursive_promise(5)
+    with_promise_domain(cd2, {
+      p %...>%
+        {
+          # This time, none of the ones inside recursive_promise count, since
+          # they were bound outside of the influence of cd2 (even though they
+          # are resolved within the influence of cd2, thanks to wait_for_it()).
+          expect_identical(cd2$counts$onFulfilledCalled, 1L)
+        } %>%
+        wait_for_it()
+    })
+
+  })
 })