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

@@ -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

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)
+             unknown
-             #f)]
+             (get-error-message v))]
-        [else #f]))
+        [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 ()
+                             (if (= n 1)
-				 (cond
+                                 (flush-ssl mzssl #f)
-				  [(= err SSL_ERROR_WANT_READ)
+                                 (cond
-				   (pump-input-once mzssl (if out-blocked? (mzssl-o mzssl) #t))
+                                  [(= err SSL_ERROR_WANT_READ)
-				   (loop cnt)]
+                                   (let ([out-blocked? (pump-output mzssl)])
-				  [(= err SSL_ERROR_WANT_WRITE)
+                                     (pump-input-once mzssl (if out-blocked? (mzssl-o mzssl) #t)))
-				   (pump-output-once mzssl #t #f)
+                                   (loop cnt)]
-				   (loop cnt)]
+                                  [(= err SSL_ERROR_WANT_WRITE)
-				  [else
+                                   (pump-output-once mzssl #t #f)
-				   (if (= n 0)
+                                   (loop cnt)]
-				       ;; When 0 is returned, the SSL object doesn't correctly
+                                  [else
-				       ;; report what it wants (e.g., a write). Send everything
+                                   (if (= n 0)
-				       ;; out that we have and try again, up to 10 times.
+                                       ;; When 0 is returned, the SSL object doesn't correctly
-				       (unless (cnt . >= . 10)
+                                       ;; report what it wants (e.g., a write). Send everything
-					 (loop (add1 cnt)))
+                                       ;; out that we have and try again, up to 10 times.
-				       ((mzssl-error mzssl) 'read-bytes 
+                                       (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]))]

collects/tests/openssl/basic.rkt

@@ -1,13 +1,22 @@
-
+#lang racket
-(load-relative "loadtest.rktl")
-
-(Section 'openssl)
-
 (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-input-port r)
-		  (close-output-port w)))))
+                  (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)
 
-
+(newline)
-(report-errs)
+(when errs?
+  (error "There were test failures"))
+(printf "All tests passed.\n")

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/"))