From 0f926e79405917f6e37bba92bc7742aa0c847610 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 7 May 2019 12:07:30 +0100
Subject: [PATCH] New "test" illustrating aspects of the turn-based approach
 taken

---
 imperative/test/core/pending-changes.rkt | 108 +++++++++++++++++++++++
 1 file changed, 108 insertions(+)
 create mode 100644 imperative/test/core/pending-changes.rkt

diff --git a/imperative/test/core/pending-changes.rkt b/imperative/test/core/pending-changes.rkt
new file mode 100644
index 0000000..d9a01b3
--- /dev/null
+++ b/imperative/test/core/pending-changes.rkt
@@ -0,0 +1,108 @@
+#lang imperative-syndicate/test-implementation
+;;
+;; In principle, we might like that actors within a turn should
+;; respond to assertions currently in the database *as modified by
+;; previous pending actions of the actor*. However, this doesn't
+;; currently work. Not only does the imperative-syndicate
+;; implementation not do this, the old syndicate implementation
+;; doesn't do it either, and there's also a theoretical problem: Say
+;; we had been asserting `'x`, and within a single turn, we retract it
+;; and establish a facet responding to it. Should the new facet react
+;; to `'x`? The answer can only be "maybe", because our own assertion
+;; of `'x` may not be the only one in the dataspace. Therefore,
+;; perhaps it's best just to keep the current situation, or its ideal
+;; reflection perhaps, which is: within-turn actions should execute in
+;; context of the dataspace state as it was at the beginning of the
+;; turn. I'm not 100% sure whether the current implementation actually
+;; provides this guarantee, but it must be quite close since it seems
+;; to hold for the examples I've tried.
+;;
+;; This line of thinking is in reaction to an infelicity I noticed
+;; while working on the client/server/federation code. The following
+;; code, on connection drop, runs through the `boot-connection` loop
+;; *twice* instead of just once, because the retraction of
+;; `server-connected` hasn't had time to actually be reflected in the
+;; dataspace by the time the reaction to `server-connected` is
+;; (re)established. The `server-connected` record is withdrawn on the
+;; next turn, leading to a second `boot-connection`, and the system
+;; stabilises here because `server-connected` is no longer present.
+;;
+;;   (let boot-connection ()
+;;     (define root-facet (current-facet))
+;;     (log-info "boot-connection ~v ~a" (current-facet) (facet-live? (current-facet)))
+;;
+;;     (reassert-on (tcp-connection id (tcp-address host port))
+;;                  (retracted (tcp-accepted id))
+;;                  (asserted (tcp-rejected id _)))
+;;
+;;     (during (tcp-accepted id)
+;;       (on-start (log-info "+tcp-accepted ~v ~a" (current-facet) id))
+;;       (on-stop (log-info "-tcp-accepted ~v ~a" (current-facet) id))
+;;       (assert (server-connected address))
+;;       (define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p)))))
+;;       (on (message (tcp-in id $bs)) (accumulate! bs)))
+;;
+;;     (during (server-connected address)
+;;       (on-start (log-info "+server-connected ~v ~a" (current-facet) address))
+;;       (on-stop (log-info "-server-connected ~v ~a" (current-facet) address))
+;;       ;; (on-start (send! (tcp-out id (encode (Connect scope)))))
+;;       (generic-client-session-facet address (lambda (x) (send! (tcp-out id (encode x)))))
+;;       (on-stop (log-info "---- ~v" (current-facet))
+;;                (stop-facet root-facet
+;;                            (log-info "!!!! ~v" (current-facet))
+;;                            (react (boot-connection))))))
+;;
+;; The following test case is simplified but analogous to the problem
+;; I noticed. Note particularly the `(flush!)` call, which is needed
+;; to force the retraction of `'y` through to the dataspace and back
+;; to the actor, so that the next `retry` doesn't improperly react to
+;; a soon-to-be-retracted assertion of `'y`.
+
+(test-case
+    [
+     (spawn* (until (asserted (observe 'x)))
+             (send! 'x))
+
+     ;; (spawn (on (asserted $anything) (printf "+ ~a\n" anything))
+     ;;        (on (retracted $anything) (printf "- ~a\n" anything))
+     ;;        (on (message $anything) (printf "! ~a\n" anything)))
+
+     (spawn (let retry ((n 0))
+              (cond [(>= n 10) (printf "Exceeded count\n")]
+                    [else
+                     (define f (current-facet))
+                     ;; (during 'x (assert 'y))
+                     (on (message 'x)
+                         (react (assert 'y)
+                                (on (asserted (observe 'go))
+                                    (send! 'go))))
+                     (during ($ val 'y)
+                       (on-start (printf "+++++ ~a\n" val))
+                       (on-stop (printf "----- ~a\n" val))
+                       (on (message 'go)
+                           (printf "going\n")
+                           (stop-current-facet))
+                       (on-stop
+                        (printf "stopping\n")
+                        (stop-facet f
+                                    (printf "calling retry\n")
+                                    (flush!) ;; !!!! Crucial!
+                                    (react (retry (+ n 1))))))])))
+     ]
+  no-crashes
+  (expected-output (list "+++++ y"
+                         "going"
+                         "----- y"
+                         ;;
+                         ;; (If we comment out the `(flush!)` above,
+                         ;;  the following additional events appear
+                         ;;  here, reflecting the unwanted reaction to
+                         ;;  the doomed `'y` assertion:)
+                         ;;
+                         ;; "stopping"
+                         ;; "calling retry"
+                         ;; "+++++ y"
+                         ;; "----- y"
+                         ;;
+                         "stopping"
+                         "calling retry")))