X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=tests%2Ftest-actors.scm;h=873085eb7aca925014d38be2df3c9f09f4e4c28d;hb=38afa0b278e17953b64764d800beaaa6368f70be;hp=15191c4bbbc00b6582f9ffb643d33a5d119b2a07;hpb=5985528115e276d273a6a4bb1df57c93cab61f84;p=8sync.git diff --git a/tests/test-actors.scm b/tests/test-actors.scm index 15191c4..873085e 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -18,144 +18,80 @@ (define-module (tests test-actors) #:use-module (srfi srfi-64) - #:use-module (8sync systems actors) + #:use-module (8sync actors) + #: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 -;;; ============= - -(let ((monkey-message - (make-message 'id 'to 'from 'action - '((monkey . banana))))) - ;; A key we have - (test-equal (message-ref monkey-message 'monkey) - 'banana) - - ;; A key we don't have - (let ((caught-error #f)) - (catch 'message-missing-key - (lambda () - (message-ref monkey-message 'coo-coo)) - (lambda (. args) - (set! caught-error #t))) - (test-assert caught-error)) - - ;; A key we don't have, with a default set - (test-equal (message-ref monkey-message 'coo-coo 'danger-danger) - 'danger-danger)) - - -;; 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 systems actors) message-replied) - (@@ (8sync systems actors) message-deferred-reply)))) - - -;;; Test reply / autoreply -;;; ====================== - -(define-simple-actor - ((pester-rep actor message) - (~display "customer> I'm calling customer service about this!\n") - (let ((reply (send-message-wait actor (message-ref message 'who-to-call) - 'field-call))) - (if (message-ref reply '*auto-reply* #f) - (~display "customer> Whaaaaat? I can't believe I got voice mail!\n") - (begin - (~format "*customer hears*: ~a\n" (message-ref reply 'msg)) - (let ((reply (reply-message-wait - actor reply - #:msg "Yes, it didn't work, I'm VERY ANGRY!"))) - (if (message-ref reply '*auto-reply* #f) - (~display "customer> Well then! Harumph.\n") - (error "Not an autoreply? What's going on here...")))))))) - -(define-simple-actor - ((field-call actor message) - (~display "good-rep> Hm, another call from a customer...\n") - (let ((reply - (reply-message-wait - actor message - #:msg "Have you tried turning it off and on?"))) - (~format "*rep hears*: ~a\n" (message-ref reply 'msg)) - (~display "good-rep> I'm sorry, that's all I can do for you.\n")))) - -(define-simple-actor - ((field-call 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 (ez-run-hive - hive - (list (hive-bootstrap-message hive customer 'pester-rep - #:who-to-call diligent-rep)))) - (displayed-text (get-output-string (%record-out)))) - (test-equal - displayed-text - "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"))) - ;; * Playing a tape of a lazy service rep * - (parameterize ((%record-out (open-output-string))) - (let* ((result (ez-run-hive - hive - (list (hive-bootstrap-message hive customer 'pester-rep - #:who-to-call lazy-rep)))) - (displayed-text (get-output-string (%record-out)))) - (test-equal - displayed-text - "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")))) + +;;; 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)