New "test" illustrating aspects of the turn-based approach taken
This commit is contained in:
parent
db523a8974
commit
0ac2bb768e
|
@ -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")))
|
Loading…
Reference in New Issue