From 8f8e3b7c65914f0dd8bf9b403edbfc522b7f8e5f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 25 Jul 2014 10:06:25 +0100 Subject: [PATCH] close hole in chaperone implementation Problem, example, and solution from Sam; see the dev mailing-list post on 24-JUL-2014. When a chaperoned accessor, mutator, or property accessor is used to chaperone a struct, the chaproning procedure must not be able to see things that the chaproned accessor, mutator, or property accessor would not allow. --- .../scribblings/reference/chaperones.scrbl | 11 +- .../racket-test/tests/racket/chaperone.rktl | 127 ++++++++++++++++++ racket/src/racket/src/struct.c | 54 +++++++- 3 files changed, 188 insertions(+), 4 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 245900caae..22c3e8e22f 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -227,7 +227,13 @@ or override impersonator-property values of @racket[v]. Each @racket[orig-proc] must indicate a distinct operation. If no @racket[orig-proc]s are supplied, then no @racket[prop]s must be -supplied, and @racket[v] is returned unimpersonated.} +supplied, and @racket[v] is returned unimpersonated. + +If any @racket[orig-proc] is itself an impersonator, then a use of the +accessor or mutator that @racket[orig-proc] impersonates is redirected +for the resulting impersonated structure to use @racket[orig-proc] on +@racket[v] before @racket[redirect-proc] (in the case of accessor) or +after @racket[redirect-proc] (in the case of a mutator).} @defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))] @@ -566,6 +572,9 @@ Like @racket[impersonate-struct], but with the following refinements: @racket[orig-proc] can be @racket[struct-info] only if some other @racket[orig-proc] is supplied.} + @item{Any accessor or mutator @racket[orig-proc] that is an + @tech{impersonator} must be specifically a @tech{chaperone}.} + ]} diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index df57b03764..f738146e19 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -654,6 +654,133 @@ (test #t values (equal? d3 d1)) (test '(#t) list got?))) +;; Check use of chaperoned accessor to chaperone a structure: +(let () + (define-values (prop: prop? prop-ref) (make-struct-type-property 'prop)) + (struct x [a] + #:mutable + #:property prop: 'secret) + (define v1 (x 'secret)) + (define v2 (x 'public)) + (define v3 (x #f)) + + ;; Original accessor and mutators can get 'secret and install 'garbage: + (test 'secret x-a v1) + (test (void) set-x-a! v3 'garbage) + (test 'garbage x-a v3) + (set-x-a! v3 #f) + (test 'secret prop-ref v1) + (test 'secret prop-ref struct:x) + + (define get-a + (chaperone-procedure x-a + (lambda (s) + (values (lambda (r) + (when (eq? r 'secret) + (error "sssh!")) + r) + s)))) + (define lie-a + (impersonate-procedure x-a + (lambda (s) + (values (lambda (r) + 'whatever) + s)))) + (define set-a! + (chaperone-procedure set-x-a! + (lambda (s v) + (when (eq? v 'garbage) + (error "no thanks!")) + (values s v)))) + (define mangle-a! + (impersonate-procedure set-x-a! + (lambda (s v) + (values s 'garbage)))) + (define get-prop + (chaperone-procedure prop-ref + (case-lambda + [(s) + (values (lambda (r) + (when (eq? r 'secret) + (error "sssh!")) + r) + s)] + [(s def) + (values (lambda (r) + (when (eq? r 'secret) + (error "sssh!")) + r) + s + def)]))) + + (test 'public get-a v2) + (err/rt-test (get-a v1) exn:fail?) + + (test (void) set-a! v3 'fruit) + (test 'fruit x-a v3) + (err/rt-test (set-a! v3 'garbage) exn:fail?) + (test 'fruit x-a v3) + + (test 'whatever lie-a v1) + (test 'whatever lie-a v2) + (test (void) mangle-a! v3 'fruit) + (test 'garbage get-a v3) + (set-a! v3 #f) + + (err/rt-test (get-prop v1) exn:fail?) + (err/rt-test (get-prop struct:x) exn:fail?) + + (define (wrap v + #:chaperone-struct [chaperone-struct chaperone-struct] + #:get-a [get-a get-a] + #:set-a! [set-a! set-a!] + #:get-prop [get-prop get-prop]) + (chaperone-struct v + get-a (lambda (s v) + (when (eq? v 'secret) + (raise 'leaked!)) + v) + set-a! (lambda (s v) + v) + get-prop (lambda (s v) + (when (eq? v 'secret) + (raise 'leaked-via-property!)) + v))) + + (test 'public x-a (wrap v2)) + ;; Can't access 'secret by using `get-a` to chaperone: + (err/rt-test (x-a (wrap v1)) exn:fail?) + ;; More-nested chaperone takes precedence: + (err/rt-test (x-a (wrap (chaperone-struct v1 x-a + (lambda (s v) + (raise 'early))))) + (lambda (exn) (eq? exn 'early))) + ;; Double chaperone should be ok: + (err/rt-test (get-a (wrap v1)) exn:fail?) + ;; Can't allow 'garbage into a value chaperoned using `set-a!`: + (err/rt-test (set-x-a! (wrap v3) 'garbage) exn:fail?) + (err/rt-test (set-a! (wrap v3) 'garbage) exn:fail?) + ;; Can't access 'secret by using `get-prop` to chaperone: + (err/rt-test (prop-ref (wrap v1)) exn:fail?) + + ;; Cannot chaperone using an impersonated operation: + (err/rt-test (wrap v2 #:get-a lie-a)) + (err/rt-test (wrap v2 #:set-a! mangle-a!)) + ;; Can impersonate with impersonated operation: + (test 'whatever x-a (wrap v2 + #:chaperone-struct impersonate-struct + #:get-a lie-a + #:get-prop (let () + (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) + ;; dummy, since property accessor cannot be impersonated: + prop:blue))) + + ;; Currently, `chaperone-struct-type` does not accept + ;; a property accessor as an argument. Probably it should, + ;; in which case we need to test a chaperone put in place + ;; with `get-prop`. + (void)) + ;; ---------------------------------------- (as-chaperone-or-impersonator diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 0b9624c7c0..acfaf8f212 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1128,7 +1128,16 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object #endif arg = px->prev; - orig = do_chaperone_prop_accessor(who, prop, arg); + if (SCHEME_PAIRP(red)) { + /* Operation used to chaperone the struct was itself chaperoned. + Use the chaperoned operation to get the result to chaperone + further. */ + a[0] = arg; + orig = _scheme_apply(SCHEME_CAR(red), 1, a); + red = SCHEME_CDR(red); + } else { + orig = do_chaperone_prop_accessor(who, prop, arg); + } if (!orig) return NULL; @@ -2089,11 +2098,19 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim, } #endif - orig = chaperone_struct_ref(who, prim, px->prev, i); + red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i]; + if (SCHEME_PAIRP(red)) { + /* Operation used to chaperone the struct was itself chaperoned. + Use the chaperoned operation to get the result to chaperone + further. */ + a[0] = px->prev; + orig = _scheme_apply(SCHEME_CAR(red), 1, a); + red = SCHEME_CDR(red); + } else + orig = chaperone_struct_ref(who, prim, px->prev, i); a[0] = px->prev; a[1] = orig; - red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i]; if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) { o = _scheme_apply_native(red, 2, a); if (o == SCHEME_MULTIPLE_VALUES) { @@ -2146,8 +2163,16 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim, half = (SCHEME_VEC_SIZE(px->redirects) - PRE_REDIRECTS) >> 1; red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + half + i]; if (SCHEME_TRUEP(red)) { + Scheme_Object *finish_setter = NULL; + a[0] = o; a[1] = v; + + if (SCHEME_PAIRP(red)) { + finish_setter = SCHEME_CAR(red); + red = SCHEME_CDR(red); + } + if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) { v = _scheme_apply_native(red, 2, a); if (v == SCHEME_MULTIPLE_VALUES) { @@ -2162,6 +2187,15 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim, if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1])) scheme_wrong_chaperoned(who, "value", a[1], v); + + if (finish_setter) { + /* Operation used to chaperone the struct was itself chaperoned. + Use the chaperoned operation to finish the assignment. */ + a[0] = o; + a[1] = v; + (void)_scheme_apply_multi(finish_setter, 2, a); + return; + } } } if (SCHEME_VECTORP(px->redirects) && !(SCHEME_VEC_SIZE(px->redirects) & 1) @@ -5859,6 +5893,20 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, NULL); } + /* If the operation to chaperone was itself a chaperone, we need to + preserve and use he chaperoned variant of the operation. */ + if (SCHEME_CHAPERONEP(a[0])) { + Scheme_Chaperone *ppx = (Scheme_Chaperone *)a[0]; + if (!is_impersonator + && (SCHEME_CHAPERONE_FLAGS(ppx) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { + scheme_contract_error(name, + "impersonated operation cannot be used to create a chaperone", + "operation", 1, a[0], + NULL); + } + proc = scheme_make_pair(a[0], proc); + } + if (prop) red_props = scheme_hash_tree_set(red_props, prop, proc); else if (st)