109 lines
5.2 KiB
Racket
109 lines
5.2 KiB
Racket
#lang 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 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")))
|