X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=tests%2Ftest-actors.scm;h=873085eb7aca925014d38be2df3c9f09f4e4c28d;hb=c713ba22bcd4b489d1ccebb8b54303de2758370b;hp=68a05bf13a1b3c668f5c76430862fd06fe6410b1;hpb=c769bb3b2c949c304eb4395d3f24eebea6106c1a;p=8sync.git diff --git a/tests/test-actors.scm b/tests/test-actors.scm index 68a05bf..873085e 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -19,125 +19,79 @@ (define-module (tests test-actors) #:use-module (srfi srfi-64) #:use-module (8sync actors) - #:use-module (8sync agenda) + #:use-module (fibers) + #:use-module (fibers conditions) + #:use-module (fibers operations) + #:use-module (fibers timers) + #:use-module (ice-9 atomic) + #:use-module (ice-9 receive) #:use-module (oop goops) #:use-module (tests utils)) (test-begin "test-actors") - -;;; Test writing things to here -(define %record-out (make-parameter (open-output-string))) -(define (~display str) - (display str (%record-out))) -(define-syntax-rule (~format args ...) - (format (%record-out) args ...)) - -;;; Some test dummy values -;;; ====================== - -(define %fake-hive-id "the-main-hive") -;; Some fake ids for actors -(define %fake-emo-id (make-address "emo" %fake-hive-id)) -(define %fake-proog-id (make-address "proog" %fake-hive-id)) -(define %fake-hive-actor-id (make-address "hive" %fake-hive-id)) - -(define test-message - (make-message ((simple-message-id-generator)) - %fake-emo-id - %fake-hive-actor-id ; Bootstrap messages come from the hive - 'greet-proog `(#:target ,%fake-proog-id))) - -;;; Actor utilities -;;; =============== - -;;; Message tests -;;; ============= - -;; Make sure our test message serializes and deserializes okay - -(let ((reread-message - (read-message-from-string - (with-output-to-string - (lambda () (write-message test-message)))))) - (test-assert (message? reread-message)) - ;; Make sure that all the properties are the same from - ;; the original message to the re-read message - (for-each - (lambda (getter) - (test-equal (getter test-message) (getter reread-message))) - (list message-id message-to message-from message-action message-body - message-in-reply-to message-wants-reply - (@@ (8sync actors) message-replied)))) - - -;;; Test reply / autoreply -;;; ====================== - -(define-simple-actor - (pester-rep (wrap-apply antsy-caller-pester-rep))) - -(define* (antsy-caller-pester-rep actor message #:key who-to-call) - (~display "customer> I'm calling customer service about this!\n") - (msg-receive (first-reply #:key msg) - (<-wait actor who-to-call 'field-call) - (if (message-auto-reply? first-reply) - (~display "customer> Whaaaaat? I can't believe I got voice mail!\n") - (begin - (~format "*customer hears*: ~a\n" msg) - (msg-receive (second-reply #:key *auto-reply*) - (<-reply-wait actor first-reply - #:msg "Yes, it didn't work, I'm VERY ANGRY!") - (if (message-auto-reply? second-reply) - (~display "customer> Well then! Harumph.\n") - (error "Not an autoreply? What's going on here..."))))))) - -(define-simple-actor - (field-call (wrap-apply rep-field-call))) - -(define (rep-field-call actor message) - (~display "good-rep> Hm, another call from a customer...\n") - (msg-receive (reply #:key msg) - (<-reply-wait - actor message - #:msg "Have you tried turning it off and on?") - (~format "*rep hears*: ~a\n" msg) - (~display "good-rep> I'm sorry, that's all I can do for you.\n"))) - -(define-simple-actor - (field-call - (lambda (actor message) - (~display "lazy-rep> I'm not answering that.\n")))) - -(let* ((hive (make-hive)) - (customer (hive-create-actor* hive "antsy-caller")) - (diligent-rep (hive-create-actor* hive "diligent-rep")) - (lazy-rep (hive-create-actor* hive "lazy-rep"))) - ;; * Playing a tape of a diligent service rep * - (parameterize ((%record-out (open-output-string))) - (let* ((result (run-hive - hive - (list (bootstrap-message hive customer 'pester-rep - #:who-to-call diligent-rep)))) - (displayed-text (get-output-string (%record-out)))) - (test-equal "customer> I'm calling customer service about this! -good-rep> Hm, another call from a customer... -*customer hears*: Have you tried turning it off and on? -*rep hears*: Yes, it didn't work, I'm VERY ANGRY! -good-rep> I'm sorry, that's all I can do for you. -customer> Well then! Harumph.\n" - displayed-text))) - ;; * Playing a tape of a lazy service rep * - (parameterize ((%record-out (open-output-string))) - (let* ((result (run-hive - hive - (list (bootstrap-message hive customer 'pester-rep - #:who-to-call lazy-rep)))) - (displayed-text (get-output-string (%record-out)))) - (test-equal "customer> I'm calling customer service about this! -lazy-rep> I'm not answering that. -customer> Whaaaaat? I can't believe I got voice mail!\n" - displayed-text)))) + +;;; Test waiting on a response + +(define-actor () + ((ping-pong + (lambda (actor message ping-val) + ;; Returns two values to its continuation: its ping-val, and the + ;; value of its own response-val slot. + (values (.response-val actor) ping-val)))) + (response-val #:init-keyword #:response-val + #:accessor .response-val)) + +(define-actor () + ((run requester-run)) + (done #:init-keyword #:done + #:accessor .done) + (test-box #:init-keyword #:test-box + #:accessor .test-box)) + +(define (requester-run requester m) + (define beeper + (create-actor #:response-val 'beep)) + (define booper + (create-actor #:response-val 'boop)) + (define bopper + (create-actor #:response-val 'bop)) + (define borker + (create-actor #:response-val 'bork)) + (receive (v1 v2) + (<-wait beeper 'ping-pong 1) + (test-equal v1 'beep) + (test-equal v2 1)) + (receive (v1 v2) + (<-wait booper 'ping-pong 2) + (test-equal v1 'boop) + (test-equal v2 2)) + (receive (v1 v2) + (<-wait bopper 'ping-pong 3) + (test-equal v1 'bop) + (test-equal v2 3)) + (receive (v1 v2) + (<-wait borker 'ping-pong 4) + (test-equal v1 'bork) + (test-equal v2 4)) + (atomic-box-set! (.test-box requester) 'we-did-it) + (signal-condition! (.done requester))) + +(let ((test-box (make-atomic-box 'not-yet)) + (done (make-condition))) + (run-hive + (lambda (hive) + (define requester (create-actor + #:done done + #:test-box test-box)) + (<- requester 'run) + (perform-operation + (choice-operation (wait-operation done) + ;; if somehow this times out after 5 seconds, + ;; something is deeply wrong + (sleep-operation 5))) + (test-equal (atomic-box-ref test-box) + 'we-did-it)))) (test-end "test-actors") (test-exit)