From: Christopher Allan Webber Date: Tue, 8 Aug 2017 19:45:52 +0000 (-0500) Subject: Updated actors unit tests. X-Git-Url: https://jxself.org/git/?p=8sync.git;a=commitdiff_plain;h=c713ba22bcd4b489d1ccebb8b54303de2758370b Updated actors unit tests. Significantly cut down... we'll have to repopulate it. * tests/test-actors.scm: Removed old unit tests and added a new one. --- diff --git a/tests/test-actors.scm b/tests/test-actors.scm index c524af2..873085e 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -19,189 +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-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") - (mbody-receive (first-reply #:key msg) - (<-wait 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) - (mbody-receive (second-reply #:key *auto-reply*) - (<-reply-wait 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-actor () - ((field-call (wrap-apply rep-field-call)))) - -(define (rep-field-call actor message) - (~display "good-rep> Hm, another call from a customer...\n") - (mbody-receive (reply #:key msg) - (<-reply-wait 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-actor () - ((field-call - (lambda (actor message) - (~display "lazy-rep> I'm not answering that.\n"))))) - -(let* ((hive (make-hive)) - (customer (create-actor* "antsy-caller")) - (diligent-rep (create-actor* "diligent-rep")) - (lazy-rep (create-actor* "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)))) - -;;; Cleanup tests - -(define-actor () - ((*cleanup* test-call-cleanup))) - -(define (test-call-cleanup actor message) - (speak "Hey, I'm cleanin' up here!\n")) - -(with-fresh-speaker - (let ((hive (make-hive))) - (create-actor ) - (run-hive hive '())) - (test-equal '("Hey, I'm cleanin' up here!\n") - (get-spoken))) - -;; won't work if we turn off #:cleanup though - -(with-fresh-speaker - (let ((hive (make-hive))) - (create-actor ) - (run-hive hive '() #:cleanup #f)) - (test-equal '() - (get-spoken))) - -;; The exploder self-destructs, even though run-hive has cleanup -;; disabled, because it cleans up on self-destruct. - -(define-actor () - ((explode (lambda (exploder message) - (speak "POOF\n") - (self-destruct exploder))) - (*cleanup* (lambda _ (speak "Cleaning up post-explosion\n"))))) - -(with-fresh-speaker - (let ((hive (make-hive))) - (define exploder (create-actor )) - (run-hive hive (list (bootstrap-message hive exploder 'explode)) - #:cleanup #f)) - (test-equal '("POOF\n" "Cleaning up post-explosion\n") - (get-spoken))) - -(define-class () - (name #:init-keyword #:name) - (create-friend #:init-value #f - #:init-keyword #:create-friend) - (actions #:allocation #:each-subclass - #:init-thunk (build-actions - (*init* hi-on-init-init)))) - -(define (hi-on-init-init actor message) - (speak (format #f "Hi! ~a inits now.\n" - (slot-ref actor 'name))) - (and=> (slot-ref actor 'create-friend) - (lambda (friend-name) - (create-actor #:name friend-name)))) - -(with-fresh-speaker - (let ((hive (make-hive))) - (define hi-on-init (create-actor - #:name "jack" - #:create-friend "jill")) - (run-hive hive '())) - (test-equal (get-spoken) - '("Hi! jack inits now.\n" "Hi! jill inits now.\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)