diff --git a/goblins/vat.rkt b/goblins/vat.rkt index ddfc503..64b4123 100644 --- a/goblins/vat.rkt +++ b/goblins/vat.rkt @@ -428,6 +428,84 @@ ((list 'err _err) #t)))) + ;; Jessica edition of promise pipelining testing + (define (^borked-factory _bcom) + (define (^car _bcom) + (lambda () + (format "Vroom vroom"))) + + (match-lambda + ('make-car (spawn ^car)) + ('make-error (error "Oops! no vrooming here :(")))) + + (define (try-car-pipeline vat factory method-name) + (let ((result #f) + (is-borked? 'unknown)) + (vat + 'run + (lambda () + (define car-vow + (<- factory method-name)) + ;; mark whether or not the car ends up as borked or not + (on car-vow + (lambda (car) + (set! is-borked? #f)) + #:catch + (lambda (some-error) + (set! is-borked? #t))) + ;; try promise pipelining with the esult + (on (<- car-vow) + (lambda (car-says) + (set! result (vector 'ok car-says))) + #:catch + (lambda (some-error) + (set! result (vector 'err some-error)))))) + (sleep 0.05) + (values result is-borked?))) + + (define borked-factory (a-vat 'spawn ^borked-factory)) + + ;; Check the initial working car. + (let-values (((result is-borked?) + (try-car-pipeline a-vat borked-factory 'make-car))) + (test-true + "Sanity check to make sure factory normally works" + (and (not is-borked?) + (match result + ((vector 'ok "Vroom vroom") + #t) + (_ #f))))) + + (let-values (((result is-borked?) + (try-car-pipeline b-vat borked-factory 'make-car))) + (test-true + "Sanity check to make sure factory normally works across vats" + (and (not is-borked?) + (match result + ((vector 'ok "Vroom vroom") + #t) + (_ #f))))) + + ;; Now check the error. + (let-values (((result is-borked?) + (try-car-pipeline a-vat borked-factory 'make-error))) + (test-true + "Check promise pipeling breaks on error on the same vat" + (and is-borked? + (match result + ((vector 'err _err) #t) + (_ #f))))) + + ;; Now check that errors work across vats + (let-values (((result is-borked?) + (try-car-pipeline b-vat borked-factory 'make-error))) + (test-true + "Check promise pipeling breaks on error between vats" + (and is-borked? + (match result + ((vector 'err _err) #t) + (_ #f))))) + (define (try-remote-on-promise . resolve-args) (define fulfilled-val #f)