suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

close hole in chaperone implementation

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2014-07-25 10:06:25 +01:00
parent 70afd4b6b1
commit 8f8e3b7c65
3 changed files with 188 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -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}.}
]}

127
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -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

54
racket/src/racket/src/struct.c
View File

@ -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)