change `impersonate-struct' to require evidence that a field is mutable

When supplying an accessor to redirect, either the corresponding field
must be accessible through the current inspector, or a mutator for
the same field must be redirected, too.

Stevie realized that we need this constraint; otherwise, impersonators
can implement mutator-like behavior even when the mutator is otherwise
secret.

collects/scribblings/reference/chaperones.scrbl

@@ -189,7 +189,10 @@ The protocol for a @racket[redirect-proc] depends on the corresponding
       @racket[_field-v] that @racket[orig-proc] produces for
       @racket[v]; it must return a replacement for
       @racket[_field-v]. The corresponding field must not be
-      immutable.}
+      immutable, and either the field's structure type must be
+      accessible via the current @tech{inspector} or one of the other
+      @racket[orig-proc]s must be a structure-field mutator for the
+      same field.}
 
  @item{A structure-field mutator: @racket[redirect-proc] must accept
       two arguments, @racket[v] and the value @racket[_field-v]

collects/tests/racket/chaperone.rktl

@@ -414,12 +414,18 @@
    (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate))
    (define-struct a ([x #:mutable] y))
    (define-struct (b a) ([z #:mutable]))
+   (define-struct (c b) ([n #:mutable]) #:transparent)
    (define-struct p (u) #:property prop:green 'green)
    (define-struct (q p) (v w))
-   (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)))
+   (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)
-   (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)))
+                                                      set-a-x! (lambda (a v) v)))
+   (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)
+                                                      set-a-x! (lambda (a v) v)))
    (test #t chaperone?/impersonator (chaperone-struct (make-p 1) green-ref (lambda (a v) v)))
-   (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue))
+   (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)
+                                                      set-a-x! (lambda (a v) v)
+                                                      prop:blue 'blue))
+   (test #t chaperone?/impersonator (chaperone-struct (make-c 1 2 3 4) c-n (lambda (b v) v)))
    (when is-chaperone
      (test #t chaperone?/impersonator (chaperone-struct 
                                        (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
@@ -558,7 +564,8 @@
       (define-struct a (x [y #:mutable]) #:property prop:procedure 0)
       (let* ([a1 (make-a (lambda (x) (list x x)) 10)]
              [get #f]
-             [a2 (chaperone-struct a1 a-y (lambda (a v) (set! get v) v))]
+             [a2 (chaperone-struct a1 a-y (lambda (a v) (set! get v) v)
+                                   set-a-y! (lambda (a v) v))]
              [pre #f]
              [post #f]
              [a3 (chaperone-procedure (if linear? a2 a1)
@@ -569,7 +576,8 @@
                                                   r)
                                                 z)))]
              [a2 (if rev?
-                     (chaperone-struct a3 a-y (lambda (a v) (set! get v) v))
+                     (chaperone-struct a3 a-y (lambda (a v) (set! get v) v)
+                                       set-a-y! (lambda (a v) v))
                      a2)])
         (test #t a? a1)
         (test #t a? a2)

doc/release-notes/racket/HISTORY.txt

@@ -4,6 +4,9 @@ Added raise-argument-error, raise-result-error,
  raise-arguments-error, raise-range-error
 racket/contract: added procedure-arity-includes/c
 racket/sandbox: added sandbox-propagate-exceptions
+Changed impersonate-struct so that accessor impersonation requires
+ work only if the field is accessible via the current impersonator
+ or a mutator for the same field is also impersonated
 
 Version 5.3.0.8
 Required modules are instantiated in the order that they are required

src/racket/src/struct.c

@@ -5155,10 +5155,10 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
   Scheme_Object *val = argv[0], *proc;
   Scheme_Object *redirects, *prop, *si_chaperone = scheme_false;
   Struct_Proc_Info *pi;
-  Scheme_Object *a[1];
+  Scheme_Object *a[1], *inspector, *getter_positions = scheme_null;
   int i, offset, arity, non_applicable_op, repeat_op;
   const char *kind;
-  Scheme_Hash_Tree *props = NULL, *red_props = NULL;
+  Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL;
 
   if (argc == 1) return argv[0];
 
@@ -5175,6 +5175,11 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
     redirects = NULL;
   }
 
+  if (is_impersonator)
+    inspector = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
+  else
+    inspector = NULL;
+
   for (i = 1; i < argc; i++) {
     proc = argv[i];
 
@@ -5254,16 +5259,33 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
         repeat_op = 1;
       else {
         if (is_impersonator) {
+          intptr_t field_pos;
+          field_pos = pi->field - (pi->struct_type->name_pos 
+                                   ? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots 
+                                   : 0);
           /* Must not be an immutable field. */
           if (stype->immutables) {
-            if (stype->immutables[pi->field - (pi->struct_type->name_pos 
+            if (stype->immutables[field_pos])
-                                               ? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots 
-                                               : 0)])
               scheme_contract_error(name,
                                     "cannot replace operation for an immutable field",
                                     "operation kind", 0, kind,
                                     "operation procedure", 1, a[0],
-                                           NULL);
+                                    NULL);
+          }
+          if (!offset) {
+            /* impersonating a getter is allowed only if the structure type is
+               transparent or if the setter is also impersonated (which would prove
+               that the code creating the impersonator has suitable access). */
+            if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) {
+              getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(pi->field), a[0]),
+                                                  getter_positions);
+            }
+          } else {
+            if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) {
+              if (!setter_positions)
+                setter_positions = scheme_make_hash_tree(0);
+              setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(pi->field), scheme_true);
+            }
           }
         }
       }
@@ -5315,6 +5337,25 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
       si_chaperone = proc;
   }
 
+  if (is_impersonator) {
+    /* For each getter for a non-transparent field, check that a witness
+       setter was provided */
+    getter_positions = scheme_reverse(getter_positions);
+    while (!SCHEME_NULLP(getter_positions)) {
+      prop = SCHEME_CAR(getter_positions);
+      if (!setter_positions
+          || !scheme_hash_tree_get(setter_positions, SCHEME_CAR(prop))) {
+        scheme_contract_error(name,
+                              "accessor redirection for a non-transparent field requires a mutator redirection",
+                              "explanaion", 0, "a mutator redirection acts as a witness that access is allowed",
+                              "accessor", 1, SCHEME_CDR(prop),
+                              "value to impersonate", 1, argv[0],
+                              NULL);
+      }
+      getter_positions = SCHEME_CDR(getter_positions);
+    }
+  }
+  
   if (!redirects) {
     /* a non-structure chaperone */
     redirects = scheme_make_vector(1, NULL);