From a976c56cb91bf08dd6de4c43c502a6e010ba48a9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Mar 2012 15:50:06 -0700 Subject: [PATCH] openssl: more little fixes Fix an error message broken by earlier debugging, and also fix long-standing shutdown problems. Move basic tests to more standard location. --- collects/meta/props | 1 - collects/openssl/mzssl.rkt | 50 ++++++++++--------- .../openssl.rktl => openssl/basic.rkt} | 31 ++++++++---- .../tests/openssl/{github.rkt => https.rkt} | 1 + 4 files changed, 49 insertions(+), 34 deletions(-) rename collects/tests/{racket/openssl.rktl => openssl/basic.rkt} (75%) rename collects/tests/openssl/{github.rkt => https.rkt} (83%) diff --git a/collects/meta/props b/collects/meta/props index 83b0cd85d6..f6fe7c482c 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1849,7 +1849,6 @@ path/s is either such a string or a list of them. "collects/tests/racket/object-old.rktl" drdr:command-line #f "collects/tests/racket/object.rktl" drdr:command-line #f "collects/tests/racket/oe.rktl" drdr:command-line (racket "-f" *) -"collects/tests/racket/openssl.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/optimize.rktl" drdr:command-line #f "collects/tests/racket/pack.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/package-gen.rktl" drdr:command-line (racket "-f" *) drdr:timeout 600 diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index 80289223aa..5bcad18855 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -315,6 +315,7 @@ (define e (if (positive? v) 0 (SSL_get_error ssl v))) + (define unknown "(unknown error)") (define estr (cond [(= e SSL_ERROR_SSL) @@ -322,9 +323,9 @@ [(= e SSL_ERROR_SYSCALL) (define v (ERR_get_error)) (if (zero? v) - (get-error-message v) - #f)] - [else #f])) + unknown + (get-error-message v))] + [else unknown])) (values v e estr))) (define-syntax-rule (save-errors e ssl) @@ -649,7 +650,7 @@ [else (set! must-read-len #f) ((mzssl-error mzssl) 'read-bytes - "SSL read failed ~a ~a" + "SSL read failed ~a" estr)]))))))] [top-read (lambda (buffer) @@ -879,28 +880,31 @@ ;; issue shutdown (i.e., EOF on read end) (when (mzssl-shutdown-on-close? mzssl) (let loop ([cnt 0]) - (let ([out-blocked? (flush-ssl mzssl #f)]) + (let () + (flush-ssl mzssl #f) (let-values ([(n err estr) (save-errors (SSL_shutdown (mzssl-ssl mzssl)) (mzssl-ssl mzssl))]) - (unless (= n 1) - (let () - (cond - [(= err SSL_ERROR_WANT_READ) - (pump-input-once mzssl (if out-blocked? (mzssl-o mzssl) #t)) - (loop cnt)] - [(= err SSL_ERROR_WANT_WRITE) - (pump-output-once mzssl #t #f) - (loop cnt)] - [else - (if (= n 0) - ;; When 0 is returned, the SSL object doesn't correctly - ;; report what it wants (e.g., a write). Send everything - ;; out that we have and try again, up to 10 times. - (unless (cnt . >= . 10) - (loop (add1 cnt))) - ((mzssl-error mzssl) 'read-bytes + + (if (= n 1) + (flush-ssl mzssl #f) + (cond + [(= err SSL_ERROR_WANT_READ) + (let ([out-blocked? (pump-output mzssl)]) + (pump-input-once mzssl (if out-blocked? (mzssl-o mzssl) #t))) + (loop cnt)] + [(= err SSL_ERROR_WANT_WRITE) + (pump-output-once mzssl #t #f) + (loop cnt)] + [else + (if (= n 0) + ;; When 0 is returned, the SSL object doesn't correctly + ;; report what it wants (e.g., a write). Send everything + ;; out that we have and try again, up to 10 times. + (unless (cnt . >= . 10) + (loop (add1 cnt))) + ((mzssl-error mzssl) 'read-bytes "SSL shutdown failed ~a" - estr))]))))))) + estr))])))))) (set-mzssl-w-closed?! mzssl #t) (mzssl-release mzssl) #f]))] diff --git a/collects/tests/racket/openssl.rktl b/collects/tests/openssl/basic.rkt similarity index 75% rename from collects/tests/racket/openssl.rktl rename to collects/tests/openssl/basic.rkt index aecd9e8be0..ec4ec1912b 100644 --- a/collects/tests/racket/openssl.rktl +++ b/collects/tests/openssl/basic.rkt @@ -1,13 +1,22 @@ - -(load-relative "loadtest.rktl") - -(Section 'openssl) - +#lang racket (require openssl/mzssl) (define pem (build-path (collection-path "openssl") "test.pem")) +(define errs? #f) +(define (test expect f . args) + (printf "~s ~s => " f args) + (define v (apply f args)) + (printf "~s\n" v) + (unless (equal? expect v) + (printf "BUT EXPECTED ~s\n" expect) + (set! errs? #t))) + +(define-syntax-rule (err/rt-test e exn?) + (test 'ok values (with-handlers ([exn? (lambda (x) 'ok)]) + e))) + (define (test-ssl limit buffer? close?) ;; Test SSL communication using a limited pipe. ;; (Using a pipe limited to a small buffer helps make sure @@ -29,8 +38,8 @@ (flush-output w)) (test "hello" read-string 5 r) (test eof read-string 5 r) - (close-input-port r) - (close-output-port w))))) + (close-input-port r) + (close-output-port w))))) (define t2 (thread (lambda () (define ctx (ssl-make-server-context 'sslv2-or-v3)) @@ -47,7 +56,7 @@ (close-output-port w))))) (thread-wait t1) (thread-wait t2) - ;; Check that ports were closed not: + ;; Check that ports were closed or not: (if close? (begin (err/rt-test (read-byte r1) exn:fail?) @@ -70,5 +79,7 @@ (test-ssl 100 #t #f) (test-ssl 100 #f #f) - -(report-errs) +(newline) +(when errs? + (error "There were test failures")) +(printf "All tests passed.\n") diff --git a/collects/tests/openssl/github.rkt b/collects/tests/openssl/https.rkt similarity index 83% rename from collects/tests/openssl/github.rkt rename to collects/tests/openssl/https.rkt index d53c822c23..dd99bf0439 100644 --- a/collects/tests/openssl/github.rkt +++ b/collects/tests/openssl/https.rkt @@ -1,6 +1,7 @@ #lang racket/base (require net/url) +;; try a basic HTTPS connection: (unless (input-port? (get-pure-port (string->url "https://api.github.com/"))) (error "failed for https://api.github.com/"))