diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 3f40a5791b..32703d67df 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require "mz.rkt") @(require (for-label syntax/modcollapse - racket/stxparam)) + racket/stxparam + racket/serialize)) @(define contract-eval (lambda () @@ -1785,6 +1786,11 @@ the original structure-type name does not act as a constructor. If the @racket[#:omit-constructor] option is present, the constructor is not provided. +Note that if the struct is created with @racket[serializable-struct] +or @racket[define-serializable-struct], @racket[contract-out] does not +protect struct instances that are created via +@racket[deserialize]. Consider using @racket[struct-guard/c] instead. + The @racket[#:∃], @racket[#:exists], @racket[#:∀], and @racket[#:forall] clauses define new abstract contracts. The variables are bound in the remainder of the @racket[contract-out] form to new contracts that hide @@ -1842,6 +1848,19 @@ except that a @racket[_contract-expr] within @racket[provide/contract] is evaluated at the position of the @racket[provide/contract] form instead of at the end of the enclosing module.} +@defform[(struct-guard/c contract-expr ...)]{ + Returns a procedure suitable to be passed as the @racket[#:guard] + argument to @racket[struct], @racket[serializable-struct] (and related forms). + The guard procedure ensures that each contract protects the + corresponding field values, as long as the struct is not mutated. + Mutations are not protected. + + @examples[#:eval (contract-eval) #:once + (struct snake (weight hungry?) + #:guard (struct-guard/c real? boolean?)) + (eval:error (snake 1.5 "yep"))] +} + @subsection{Nested Contract Boundaries} @defmodule*/no-declare[(racket/contract/region)] @declare-exporting-ctc[racket/contract/region] diff --git a/pkgs/racket-doc/scribblings/reference/serialization.scrbl b/pkgs/racket-doc/scribblings/reference/serialization.scrbl index d1f6ae859d..a403fe578d 100644 --- a/pkgs/racket-doc/scribblings/reference/serialization.scrbl +++ b/pkgs/racket-doc/scribblings/reference/serialization.scrbl @@ -436,8 +436,8 @@ serializable with @racket[serialize]. This form is allowed only at the top level or in a module's top level (so that deserialization information can be found later). -Serialization only supports cycles involving the created structure -type when all fields are mutable (or when the cycle can be broken +Serialization supports cycles involving the created structure +type only when all fields are mutable (or when the cycle can be broken through some other mutable value). In addition to the bindings generated by @racket[struct], @@ -456,6 +456,11 @@ information bound to @racketidfont{deserialize-info:}@racket[_id]@racketidfont{-v0}. See @racket[make-deserialize-info] for more information. +Beware that the previous paragraph means that if a serializable struct +is exported via @racket[contract-out], for example, the contracts are not +checked during deserialization. Consider using @racket[struct-guard/c] +instead. + The @racket[-v0] suffix on the deserialization enables future versioning on the structure type through @racket[serializable-struct/versions]. diff --git a/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt index 45d8023be1..c2d937537e 100644 --- a/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt +++ b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt @@ -3,7 +3,7 @@ (require "test-util.rkt") (parameterize ([current-contract-namespace - (make-basic-contract-namespace)]) + (make-basic-contract-namespace 'racket/contract/region)]) (test/spec-passed 'struct-type-prop.1 '(let () @@ -73,5 +73,34 @@ (struct s (f) #:property prop (λ (x) (s-f x))) (define s3 (s list?)) ((prop-ref s3) 'apple))) + + (test/spec-failed + 'struct-guard/c.1 + '(let () + (with-contract pos + #:result any/c + (let () + (struct s (x y) #:guard (struct-guard/c integer? boolean?)) + (s 1 1)))) + "(region pos)") + + (test/spec-failed + 'struct-guard/c.2 + '(let () + (with-contract pos + #:result any/c + (let () + (struct s (x y) #:guard (struct-guard/c integer? boolean?)) + (s #t #f)))) + "(region pos)") + + (test/spec-passed/result + 'struct-guard/c.3 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^the-name-of-the-struct, field 2:" + (exn-message x)))]) + (struct the-name-of-the-struct (x y) #:guard (struct-guard/c integer? boolean?)) + (the-name-of-the-struct 1 1)) + #t) + ) diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index dd7baec78a..cdf109567c 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -143,6 +143,7 @@ get/build-val-first-projection suggest/c + struct-guard/c ;; not documented.... (ie unintentional export) n->th) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 968c26eaac..928270d750 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -71,7 +71,7 @@ (define (apply-contract c v pos neg name loc context-limit) ((make-apply-contract c pos neg name loc context-limit) v)) -(define (make-apply-contract c pos neg name loc context-limit) +(define (make-apply-contract c pos neg name loc context-limit [backwards? #f]) (let ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (define clnp (contract-late-neg-projection c)) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index 67df9eb1ad..6d5b8bc6dd 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -446,6 +446,10 @@ (define (blame/important-original? blme) (define i (blame-important blme)) (cond + [(equal? (blame-positive blme) (blame-negative blme)) + ;; if the positive and negative parties are the same, + ;; we never want to say "broke its own contract" + #f] [i (equal? (important-sense-swapped? i) (blame-original? blme))] [else (blame-original? blme)])) diff --git a/racket/collects/racket/contract/private/struct-prop.rkt b/racket/collects/racket/contract/private/struct-prop.rkt index eb7935ec5c..08a405f279 100644 --- a/racket/collects/racket/contract/private/struct-prop.rkt +++ b/racket/collects/racket/contract/private/struct-prop.rkt @@ -1,8 +1,12 @@ #lang racket/base (require "guts.rkt" "blame.rkt" - "prop.rkt") -(provide (rename-out [struct-type-property/c* struct-type-property/c])) + "prop.rkt" + "base.rkt" + (for-syntax racket/base) + syntax/location) +(provide (rename-out [struct-type-property/c* struct-type-property/c]) + struct-guard/c) (define (get-stpc-late-neg-proj stpc) (define get-late-neg-proj @@ -47,3 +51,61 @@ (struct-type-property/c (coerce-contract 'struct-type-property/c value-contract)))]) struct-type-property/c)) + +(define-syntax (struct-guard/c stx) + (syntax-case stx () + [(_ . args) + #`(struct-guard/c/proc (quote-srcloc #,stx) + (current-contract-region) + . args)])) + +(define (struct-guard/c/proc loc blame-party . ctc-args) + (define ctcs + (for/list ([arg (in-list ctc-args)] + [i (in-naturals)]) + (define ctc (coerce-contract/f arg)) + (unless ctc + (apply raise-argument-error + 'struct-guard/c + "contract?" + i + ctc-args)) + ctc)) + + ;; don't want to depend on racket/list, so duplicate this + ;; (plus we know that it will always be a non-empty list, + ;; so skip some checks) + (define (last l) + (let loop ([l l]) + (if (pair? (cdr l)) (loop (cdr l)) (car l)))) + + (define number-of-contracts (length ctcs)) + + ;; would like to have this be specialized to the number of + ;; arguments there actually are, but given the fact that + ;; we're creating blame objects and projections after getting + ;; the arguments it doesn't seem worth bothering for now + ;; (we are creating the projections late because we don't + ;; get the `name` until later on) + (λ args + (define name (last args)) + (unless (= (length args) (+ number-of-contracts 1)) + (error 'struct-guard/c + "given ~a contracts, but the struct ~s has ~a fields" + number-of-contracts + name + (- (length args) 1))) + (define ctc-projs + (for/list ([ctc (in-list ctcs)] + [i (in-naturals 1)]) + (make-apply-contract ctc + blame-party blame-party + (if (= number-of-contracts 1) + name + (format "~a, field ~a" name i)) + loc + #f))) + (apply values + (for/list ([arg (in-list args)] + [proj (in-list ctc-projs)]) + (proj arg)))))