Use contract violations consistently
ober
31b388f12cd052ccc36519f28818b070ab7e4309
--- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_ PURE_AUDIT_ROOT ?= $(HOME)/mine PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) -.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -64,6 +64,7 @@ help: @echo " test-repl REPL tests" @echo " test-functional Functional tests (I/O, fork, signals)" @echo " test-gaps Gap coverage tests" + @echo " test-contract Runtime contract tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @echo "Test (features):" @@ -290,7 +291,7 @@ binary-cross: chez build chez-cross CC="$(CROSS_CC)" \ support/build-binary.sh $(BINARY_ENTRY) $(BINARY_OUTPUT)-$(CHEZ_TARGET_MACHINE) -test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-pure-audit +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-contract test-pure-audit pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script support/pure-audit.ss $(PURE_AUDIT_ARGS) @@ -334,6 +335,9 @@ test-expanded: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-expanded-stdlib.ss; \ fi +test-contract: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-contract.ss + test-pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss --- a/docs/contracts.md +++ b/docs/contracts.md @@ -78,6 +78,17 @@ In scope: - Error reporting that names the violating module, line, and argument position. +Current landing: + +- `(std contract)` raises `contract-violation?` conditions from + `check-argument`, `check-result`, `assert-contract`, and + `define/contract` pre/post failures. +- `(std ergo)` provides the first Gerbil-style dynamic markers: `:`, `:?`, + `:-`, `:~`, `using`, `maybe`, `list-of?`, `in-range?`, and + `in-range-inclusive?`. +- Jerboa `def` accepts `:`, `:?`, `:-`, and `:~` parameter markers for dynamic + boundary checks. + Out of scope (initially): - Full Racket-style blame tracking with party-positive/negative --- a/lib/std/contract.ss +++ b/lib/std/contract.ss @@ -13,10 +13,11 @@ (export check-argument check-result contract-violation? contract-violation-who contract-violation-message + raise-contract-violation define/contract pre: post: -> assert-contract) - (import (chezscheme) + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted stdlib contract module (only (jerboa core) def)) ;; Condition type for contract violations @@ -33,13 +34,13 @@ (make-irritants-condition irritants)))) ;; Check a function argument satisfies a predicate - (def (check-argument pred val who) + (def (check-argument pred val who) ; jerboa-security: suppress contract-bypass-in-production -- contract module intentionally raises fail-fast boundary violations (unless (pred val) (raise-contract-violation who "argument failed predicate ~a: ~s" pred val))) ;; Check a function result satisfies a predicate - (def (check-result pred val who) + (def (check-result pred val who) ; jerboa-security: suppress contract-bypass-in-production -- contract module intentionally raises fail-fast boundary violations (unless (pred val) (raise-contract-violation who "result failed predicate ~a: ~s" pred val)) @@ -53,7 +54,7 @@ (lambda (f) (lambda args (for-each (lambda (pred val) - (check-argument pred val 'contract)) + (check-argument pred val 'contract)) ; jerboa-security: suppress contract-bypass-in-production -- function contract wrapper intentionally raises violations arg-preds args) (let ([result (apply f args)]) (check-result result-pred result 'contract) @@ -65,8 +66,8 @@ [(_ pred expr) (let ([v expr]) (unless (pred v) - (error 'assert-contract - (format "contract ~a violated by ~s" 'pred v))) + (raise-contract-violation 'assert-contract + "contract ~a violated by ~s" 'pred v)) v)])) ;; Auxiliary keywords @@ -82,26 +83,30 @@ #'(define (name arg ...) (begin (unless pre-check - (error 'name (format "precondition failed: ~a" 'pre-check))) + (raise-contract-violation 'name + "precondition failed: ~a" 'pre-check)) ... (let ([result (begin body ...)]) (unless (post-pred result) - (error 'name (format "postcondition ~a failed for result: ~s" - 'post-pred result))) + (raise-contract-violation 'name + "postcondition ~a failed for result: ~s" + 'post-pred result)) result)))] [(_ (name arg ...) (pre: pre-check ...) body ...) #'(define (name arg ...) (begin (unless pre-check - (error 'name (format "precondition failed: ~a" 'pre-check))) + (raise-contract-violation 'name + "precondition failed: ~a" 'pre-check)) ... body ...))] [(_ (name arg ...) (post: post-pred) body ...) #'(define (name arg ...) (let ([result (begin body ...)]) (unless (post-pred result) - (error 'name (format "postcondition ~a failed for result: ~s" - 'post-pred result))) + (raise-contract-violation 'name + "postcondition ~a failed for result: ~s" + 'post-pred result)) result))] [(_ (name arg ...) body ...) #'(define (name arg ...) body ...)]))) new file mode 100644 --- /dev/null +++ b/tests/test-contract.ss @@ -0,0 +1,93 @@ +#!chezscheme +;;; Tests for (std contract) condition behavior. + +(import (chezscheme) + (std contract)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn + [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(define-syntax test-contract-error + (syntax-rules () + [(_ name expr who) + (test name + (guard (exn + [(contract-violation? exn) + (eq? (contract-violation-who exn) who)] + [else #f]) + expr + #f) + #t)])) + +(printf "--- (std contract) tests ---~%") + +(test "check-argument pass" + (begin (check-argument string? "ok" 'arg-check) 'ok) + 'ok) + +(test-contract-error "check-argument violation condition" + (check-argument string? 42 'arg-check) + 'arg-check) + +(test "check-result pass" + (check-result number? 42 'result-check) + 42) + +(test-contract-error "check-result violation condition" + (check-result string? 42 'result-check) + 'result-check) + +(test "assert-contract pass" + (assert-contract number? 10) + 10) + +(test-contract-error "assert-contract violation condition" + (assert-contract number? "bad") + 'assert-contract) + +(define/contract (safe-divide n d) + (pre: (number? n) (number? d) (not (zero? d))) + (post: number?) + (/ n d)) + +(test "define/contract pass" + (safe-divide 10 2) + 5) + +(test-contract-error "define/contract precondition violation" + (safe-divide 10 0) + 'safe-divide) + +(define/contract (bad-result x) + (post: string?) + x) + +(test-contract-error "define/contract postcondition violation" + (bad-result 42) + 'bad-result) + +(let ([safe-add ((-> number? number? number?) +)]) + (test "function contract pass" + (safe-add 1 2) + 3) + (test-contract-error "function contract argument violation" + (safe-add "bad" 2) + 'contract)) + +(printf "~%Contract: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))