fix any-wrap/c unsoundness on opaque structures (#385)

typed-racket-lib/typed-racket/typed-racket.rkt

@@ -5,6 +5,8 @@
              "standard-inits.rkt")
  ;; these need to be available to the generated code
  "typecheck/renamer.rkt" syntax/location
+ ;; this defines the inspector that structs will use
+ "utils/inspector.rkt"
  (for-syntax (submod "base-env/prims-contract.rkt" self-ctor))
  (for-syntax "utils/struct-extraction.rkt")
  (for-syntax "typecheck/renamer.rkt")
@@ -16,6 +18,13 @@
          with-type
          (for-syntax do-standard-inits))
 
+;; This sets the inspector that typed racket structs will use, so that
+;; any-wrap/c can inspect them. This allows any-wrap/c to wrap structs
+;; that are defined in typed racket, and to fail on structs that it
+;; can't wrap safely.
+;; https://github.com/racket/typed-racket/issues/379
+;; https://github.com/racket/typed-racket/pull/385
+(current-inspector new-inspector)
 
 (define-syntax-rule (drivers [name sym] ...)
   (begin

typed-racket-lib/typed-racket/utils/any-wrap.rkt

@@ -11,7 +11,8 @@
          (only-in racket/udp udp?)
          (only-in (combine-in racket/private/promise)
                   promise?
-                  prop:force promise-forcer))
+                  prop:force promise-forcer)
+         (only-in "inspector.rkt" old-inspector))
 
 (define (base-val? e)
   (or (number? e) (string? e) (char? e) (symbol? e)
@@ -68,11 +69,12 @@
      v 
      "Attempted to use a higher-order value passed as `Any` in untyped code: ~v" v))
   
-  (define (wrap-struct neg-party s)
+  (define (wrap-struct neg-party s inspector)
     (define blame+neg-party (cons b neg-party))
     (define (extract-functions struct-type)
       (define-values (sym init auto ref set! imms par skip?)
-        (struct-type-info struct-type))
+        (parameterize ([current-inspector inspector])
+          (struct-type-info struct-type)))
       (define-values (fun/chap-list _)
         (for/fold ([res null]
                    [imms imms])
@@ -99,7 +101,9 @@
       (cond
         [par (append fun/chap-list (extract-functions par))]
         [else fun/chap-list]))
-    (define-values (type skipped?) (struct-info s))
+    (define-values (type skipped?)
+      (parameterize ([current-inspector inspector])
+        (struct-info s)))
     ;; It's ok to just ignore skipped? -- see https://github.com/racket/typed-racket/issues/203
     (apply chaperone-struct s (extract-functions type)))
  
@@ -163,7 +167,8 @@
        (for/set ([i (in-set v)]) (any-wrap/traverse i neg-party))]
       ;; could do something with generic sets here if they had
       ;; chaperones, or if i could tell if they were immutable.
-      [(? struct?) (wrap-struct neg-party v)]
+      [(? (struct?/inspector old-inspector))
+       (wrap-struct neg-party v old-inspector)]
       [(? procedure?)
        (chaperone-procedure v (lambda args (fail neg-party v)))]
       [(? promise?)
@@ -185,7 +190,10 @@
                                        blame+neg-party
                                        (values v (any-wrap/traverse v neg-party))))
                           (lambda (e) (fail neg-party v)))]
-      [_ (chaperone-struct v)]))
+      [_
+       ;; this would be unsound, see https://github.com/racket/typed-racket/issues/379
+       ;; (chaperone-struct v)
+       (fail neg-party v)]))
   any-wrap/traverse)
 
 (define any-wrap/c
@@ -194,6 +202,10 @@
    #:first-order (lambda (x) #t)
    #:late-neg-projection late-neg-projection))
 
+(define ((struct?/inspector inspector) v)
+  (parameterize ([current-inspector inspector])
+    (struct? v)))
+
 ;; Contract for "safe" struct predicate procedures.
 ;; We can trust that these obey the type (-> Any Boolean).
 (define (struct-predicate-procedure?/c x)

typed-racket-lib/typed-racket/utils/inspector.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+
+(provide old-inspector new-inspector)
+
+;; Defines a new inspector that typed racket structs will use,
+;; and make this new inspector a sub-inspector of the old one.
+;; The old one is more powerfull than the new one, so any-wrap/c
+;; can use the old one to inspect opaque structs created by
+;; typed racket.
+(define old-inspector (current-inspector))
+(define new-inspector (make-inspector old-inspector))
+

typed-racket-test/succeed/exn-any-mutation.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+(module untyped racket/base
+  (provide f)
+  (define (f x) x))
+(module typed typed/racket
+  (require typed/rackunit)
+  (struct (X) s ([i : X]) #:mutable)
+  (require/typed (submod ".." untyped)
+                 [f (-> Any (s (U Integer String)))])
+  (: s1 : (s Integer))
+  (define s1 (s 42))
+  (define s2 (ann s1 Any))
+  (define s3 (f s2))
+  (check-equal? (s-i s1) 42)
+  (check-equal? (s-i s3) 42)
+  (check-exn #rx"Attempted to use a higher-order value passed as `Any`"
+             (λ () (set-s-i! s3 "hi")))
+  (check-equal? (s-i s1) 42
+                "if the previous test hadn't errored, this would be \"hi\" with type Integer")
+  )
+(require 'typed)

typed-racket-test/succeed/pr241-variation-4.rkt

@@ -5,6 +5,8 @@
 ;; From Issue #203
 ;;   https://github.com/racket/typed-racket/issues/203
 
-(require typed-racket/utils/any-wrap)
+(require typed-racket/utils/any-wrap
+         typed-racket/utils/inspector)
+(current-inspector new-inspector)
 (struct s ())
 (contract any-wrap/c (s) 'a 'b)