From 4068b9097dbad2f003727a0a64bd59ca581f973e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Nov 2018 19:33:30 -0700 Subject: [PATCH] io: fix some test failures --- .../tests/racket/thrport.rktl | 58 ------------------- racket/src/io/file/main.rkt | 10 +++- racket/src/io/network/tcp-connect.rkt | 2 +- racket/src/io/network/tcp-listen.rkt | 2 +- racket/src/io/network/udp-send.rkt | 2 +- racket/src/io/network/udp-socket.rkt | 6 +- racket/src/io/path/api.rkt | 5 +- racket/src/io/path/simplify.rkt | 3 +- racket/src/io/print/char.rkt | 4 +- racket/src/io/print/string.rkt | 4 +- racket/src/io/security/main.rkt | 9 ++- 11 files changed, 32 insertions(+), 73 deletions(-) delete mode 100644 pkgs/racket-test-core/tests/racket/thrport.rktl diff --git a/pkgs/racket-test-core/tests/racket/thrport.rktl b/pkgs/racket-test-core/tests/racket/thrport.rktl deleted file mode 100644 index d814c08dbf..0000000000 --- a/pkgs/racket-test-core/tests/racket/thrport.rktl +++ /dev/null @@ -1,58 +0,0 @@ - -(load-relative "loadtest.rktl") - -(Section 'multi-threaded-ports) - -; Read from file with 3 threads, all writing to the same pipe -; read from pipe with 3 threads, all writing to the same output string -; compare resulting character content to the original file -(test 0 'threaded-ports - (let*-values ([(f-in) (open-input-file - (path->complete-path "testing.rktl" - (current-load-relative-directory)))] - [(p-in p-out) (make-pipe)] - [(s-out) (open-output-string)] - [(in->out) (lambda (in out) - (lambda () - (let loop () - (let ([c (read-char in)] - [dummy (lambda () 'hi)]) - (unless (eof-object? c) - (write-char c out) - (loop))))))] - [(f->p) (in->out f-in p-out)] - [(p->s) (in->out p-in s-out)] - [(sthread) (lambda (thunk) - (let ([t (thread (lambda () (sleep) (thunk)))]) - (thread-weight t 101) - t))]) - (thread - (lambda () - (for-each thread-wait - (list (sthread f->p) - (sthread f->p) - (sthread f->p))) - (close-output-port p-out))) - (for-each thread-wait - (list (sthread p->s) - (sthread p->s) - (sthread p->s))) - (let ([s (get-output-string s-out)] - [hits (make-vector 256 0)]) - (for-each (lambda (c) - (let ([n (char->integer c)]) - (vector-set! hits n (add1 (vector-ref hits n))))) - (string->list s)) - (file-position f-in 0) - (let loop () - (let ([c (read-char f-in)]) - (unless (eof-object? c) - (let ([n (char->integer c)]) - (vector-set! hits n (sub1 (vector-ref hits n)))) - (loop)))) - (let loop ([i 0][total 0]) - (if (= i 256) - total - (loop (add1 i) (+ total (abs (vector-ref hits i))))))))) - -(report-errs) diff --git a/racket/src/io/file/main.rkt b/racket/src/io/file/main.rkt index 88285fe3cd..3d0e0d8015 100644 --- a/racket/src/io/file/main.rkt +++ b/racket/src/io/file/main.rkt @@ -342,7 +342,7 @@ "") (host-> path-host))))) -(define/who (resolve-path p) +(define (do-resolve-path p who) (check who path-string? p) (define host-path (->host (path->path-without-trailing-separator (->path p)) who '(exists))) (start-atomic) @@ -363,6 +363,14 @@ [else new-path])] [else (host-> r)])) +(define/who (resolve-path p) + (do-resolve-path p who)) + +(module+ for-simplify + (provide resolve-path-for-simplify) + (define (resolve-path-for-simplify p) + (do-resolve-path p 'simplify-path))) + (define/who (expand-user-path p) (check who path-string? p) (define path (->path p)) diff --git a/racket/src/io/network/tcp-connect.rkt b/racket/src/io/network/tcp-connect.rkt index 9526f3bba5..c07168b071 100644 --- a/racket/src/io/network/tcp-connect.rkt +++ b/racket/src/io/network/tcp-connect.rkt @@ -45,7 +45,7 @@ (if port-no (format "\n port number: ~a" port-no) "")))) - (security-guard-check-network who hostname port-no #t) + (security-guard-check-network who hostname port-no 'client) (atomically (call-with-resolved-address hostname port-no diff --git a/racket/src/io/network/tcp-listen.rkt b/racket/src/io/network/tcp-listen.rkt index aee2a30b7b..bb2c611c88 100644 --- a/racket/src/io/network/tcp-listen.rkt +++ b/racket/src/io/network/tcp-listen.rkt @@ -33,7 +33,7 @@ (format "\n hostname: ~a" hostname) "") (format "\n port number: ~a" port-no)))) - (security-guard-check-network who hostname port-no #f) + (security-guard-check-network who hostname port-no 'server) (let loop ([family RKTIO_FAMILY_ANY]) ((atomically ;; Result is a thunk that might call `loop` diff --git a/racket/src/io/network/udp-send.rkt b/racket/src/io/network/udp-send.rkt index c110c701f1..7c42146f90 100644 --- a/racket/src/io/network/udp-send.rkt +++ b/racket/src/io/network/udp-send.rkt @@ -76,7 +76,7 @@ (check who string? hostname) (check who port-number? port-no) (check-bstr who bstr start end) - (security-guard-check-network who hostname port-no #t)) + (security-guard-check-network who hostname port-no 'client)) ;; ---------------------------------------- diff --git a/racket/src/io/network/udp-socket.rkt b/racket/src/io/network/udp-socket.rkt index 18d8632a2a..3e33a26854 100644 --- a/racket/src/io/network/udp-socket.rkt +++ b/racket/src/io/network/udp-socket.rkt @@ -32,7 +32,7 @@ (define/who (udp-open-socket [family-hostname #f] [family-port-no #f]) (check who string? #:or-false family-hostname) (check who port-number? #:or-false family-port-no) - (security-guard-check-network who family-hostname family-port-no #f) + (security-guard-check-network who family-hostname family-port-no 'server) (atomically (call-with-resolved-address #:who who @@ -65,7 +65,7 @@ (check who udp? u) (check who string? #:or-false hostname) (check who listen-port-number? port-no) - (security-guard-check-network who hostname port-no #f) + (security-guard-check-network who hostname port-no 'server) (atomically (call-with-resolved-address #:who who @@ -96,7 +96,7 @@ "last second and third arguments must be both #f or both non-#f" "second argument" hostname "third argument" port-no)) - (security-guard-check-network who hostname port-no #t) + (security-guard-check-network who hostname port-no 'client) (atomically (cond [(not hostname) diff --git a/racket/src/io/path/api.rkt b/racket/src/io/path/api.rkt index 5ade8cfaea..61fe9f17b7 100644 --- a/racket/src/io/path/api.rkt +++ b/racket/src/io/path/api.rkt @@ -22,7 +22,7 @@ [(p) ;; Supplying `current-directory` (as opposed to `raw:current-directory`) ;; triggers an appropriate security-guard check if needed: - (raw:path->complete-path p current-directory #:wrt-given? #f)] + (raw:path->complete-path p current-directory-for-path->complete-path #:wrt-given? #f)] [(p wrt) (raw:path->complete-path p wrt #:wrt-given? #t)])) (define/who (current-drive) @@ -46,6 +46,9 @@ (define/who current-directory (chaperone-procedure raw:current-directory (make-guard-paths who))) +(define/who current-directory-for-path->complete-path + (chaperone-procedure raw:current-directory (make-guard-paths 'path->complete-path))) + (define/who current-directory-for-user (chaperone-procedure raw:current-directory-for-user (make-guard-paths who))) diff --git a/racket/src/io/path/simplify.rkt b/racket/src/io/path/simplify.rkt index 99b5aa46a2..e3eeb20ffe 100644 --- a/racket/src/io/path/simplify.rkt +++ b/racket/src/io/path/simplify.rkt @@ -1,5 +1,6 @@ #lang racket/base (require "../file/main.rkt" + (submod "../file/main.rkt" for-simplify) "path.rkt" "check.rkt" "check-path.rkt" @@ -55,7 +56,7 @@ (loop (cdr l) base accum seen)] [(eq? 'up (car l)) (define new-base (combine base accum)) - (define target (resolve-path new-base)) + (define target (resolve-path-for-simplify new-base)) (define-values (from-base new-seen) (cond [(eq? target new-base) (values new-base seen)] diff --git a/racket/src/io/print/char.rkt b/racket/src/io/print/char.rkt index e47f2477e1..a5474bcd01 100644 --- a/racket/src/io/print/char.rkt +++ b/racket/src/io/print/char.rkt @@ -34,7 +34,7 @@ (cond [(n . <= . #xFFFF) (let ([max-length (write-string/max "#\\u" o max-length)]) - (write-string/max (pad 4 (number->string n 16)) o max-length))] + (write-string/max (pad 4 (string-upcase (number->string n 16))) o max-length))] [else (let ([max-length (write-string/max "#\\U" o max-length)]) - (write-string/max (pad 8 (number->string n 16)) o max-length))])])) + (write-string/max (pad 8 (string-upcase (number->string n 16))) o max-length))])])) diff --git a/racket/src/io/print/string.rkt b/racket/src/io/print/string.rkt index c69eedb2d5..68924dd81b 100644 --- a/racket/src/io/print/string.rkt +++ b/racket/src/io/print/string.rkt @@ -50,9 +50,9 @@ (cond [(n . <= . #xFFFF) (let ([max-length (write-bytes/max #"\\u" o max-length)]) - (write-string/max (pad 4 (number->string n 16)) o max-length))] + (write-string/max (pad 4 (string-upcase (number->string n 16))) o max-length))] [else (let ([max-length (write-bytes/max #"\\U" o max-length)]) - (write-string/max (pad 8 (number->string n 16)) o max-length))])] + (write-string/max (pad 8 (string-upcase (number->string n 16))) o max-length))])] [i (add1 i)]) (loop i i max-length))])])))) diff --git a/racket/src/io/security/main.rkt b/racket/src/io/security/main.rkt index 72592705d4..560068b5e1 100644 --- a/racket/src/io/security/main.rkt +++ b/racket/src/io/security/main.rkt @@ -78,12 +78,17 @@ ((security-guard-link-guard sg) check-who path dest) (loop (security-guard-parent sg))))) -(define/who (security-guard-check-network check-who given-host port client?) +(define/who (security-guard-check-network check-who given-host port mode) (check who symbol? check-who) (check who string? #:or-false given-host) (check who listen-port-number? #:or-false port) + (check who (lambda (s) + (or (eq? s 'client) + (eq? s 'server))) + #:contract "(or/c 'client 'server)" + mode) (define host (and given-host (string->immutable-string given-host))) (let loop ([sg (current-security-guard)]) (when sg - ((security-guard-network-guard sg) check-who host port (if client? 'client 'server)) + ((security-guard-network-guard sg) check-who host port mode) (loop (security-guard-parent sg)))))