From 2eb5fb2a55a8fa6ebfff3984ea23a9230111fc53 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 31 Mar 2009 19:35:08 +0000 Subject: [PATCH] remove openssl constraint that attempting to read must lead to an actual read svn: r14390 --- collects/openssl/mzssl.ss | 105 +++++++++++++++++++-------------- collects/openssl/openssl.scrbl | 17 +++--- 2 files changed, 71 insertions(+), 51 deletions(-) diff --git a/collects/openssl/mzssl.ss b/collects/openssl/mzssl.ss index ed26baa801..360be33d60 100644 --- a/collects/openssl/mzssl.ss +++ b/collects/openssl/mzssl.ss @@ -1,7 +1,8 @@ -;; Warn clients: when a (non-blocking) write fails to write all the -;; data, the stream is actually committed to writing the given data -;; in the future. (This requirement comes from the SSL library.) +;; Disabled when `enforce-retry?' is #f: +;; Warn clients: when a (non-blocking) write fails to write all the +;; data, the stream is actually committed to writing the given data +;; in the future. (This requirement comes from the SSL library.) ;; Another warning: data that is written and not buffered may still be ;; in flight between MzScheme and the underlying ports. A `flush-output' @@ -13,10 +14,9 @@ ;; read/write (the opposite direction) didn't finish, and so that ;; opposite must be completed, first. -(module mzssl mzscheme +(module mzssl scheme (require mzlib/foreign mzlib/port - mzlib/kw mzlib/runtime-path) (provide ssl-available? @@ -176,6 +176,7 @@ (define SSL_VERIFY_FAIL_IF_NO_PEER_CERT #x02) (define SSL_MODE_ENABLE_PARTIAL_WRITE #x01) + (define SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER #x02) (define SSL_CTRL_MODE 33) (define-mzscheme scheme_start_atomic (-> _void)) @@ -186,6 +187,15 @@ ;; 4096 of unencrypted data (define BUFFER-SIZE 8000) + ;; The man pages for SSL_read and SSL_write say that they must be + ;; retried with the same arguments when they return SSL_ERROR_WANT_READ + ;; or SSL_ERROR_WANT_WRITE. This may not actually be true, especially + ;; when SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER is used, and "retry" may or + ;; may not mean "retry without doing other things first". Set `enforce-retry?' + ;; to #t to obey the manpage and retry without doing other things, which + ;; has an implicitation for clients as noted at the top of this file. + (define enforce-retry? #f) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Error handling @@ -268,7 +278,8 @@ refcount close-original? shutdown-on-close? finalizer-cancel - error)) + error) + #:mutable) (define (make-immobile-bytes n) (if 3m? @@ -312,16 +323,15 @@ (atomically ; so we reliably register the finalizer (let ([ctx (SSL_CTX_new meth)]) (check-valid ctx who "context creation") - (SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE) + (SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE + SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER)) (register-finalizer ctx (lambda (v) (SSL_CTX_free v))) ((if client? make-ssl-client-context make-ssl-server-context) ctx))))) - (define/kw (ssl-make-client-context - #:optional [protocol-symbol default-encrypt]) + (define (ssl-make-client-context [protocol-symbol default-encrypt]) (make-context 'ssl-make-client-context protocol-symbol "" #t)) - (define/kw (ssl-make-server-context - #:optional [protocol-symbol default-encrypt]) + (define (ssl-make-server-context [protocol-symbol default-encrypt]) (make-context 'ssl-make-server-context protocol-symbol "" #f)) (define (get-context who context-or-encrypt-method client?) @@ -350,7 +360,7 @@ "path or string" pathname)) (let ([path (path->bytes - (path->complete-path (expand-path pathname) + (path->complete-path (cleanse-path pathname) (current-directory)))]) (let ([n (load-it ctx path)]) (unless (= n 1) @@ -379,8 +389,8 @@ 1)))) ssl-listener pathname)) - (define/kw (ssl-load-private-key! ssl-context-or-listener pathname - #:optional [rsa? #t] [asn1? #f]) + (define (ssl-load-private-key! ssl-context-or-listener pathname + [rsa? #t] [asn1? #f]) (ssl-load-... 'ssl-load-private-key! (lambda (ctx path) @@ -491,7 +501,7 @@ (set! must-read-len #f) (if must-read-len ;; If we were forced to try to read a certain amount, - ;; then we may have reda too much for the immediate + ;; then we may have read too much for the immediate ;; request. (let ([orig-n (bytes-length buffer)]) (bytes-copy! buffer 0 xfer-buffer 0 (min n orig-n)) @@ -507,11 +517,13 @@ (set! must-read-len #f) eof] [(= err SSL_ERROR_WANT_READ) - (set! must-read-len len) + (when enforce-retry? + (set! must-read-len len)) (let ([n (pump-input-once mzssl #f)]) (if (eq? n 0) (begin - (set-mzssl-must-read! mzssl (make-semaphore)) + (when enforce-retry? + (set-mzssl-must-read! mzssl (make-semaphore))) (wrap-evt (choice-evt (mzssl-i mzssl) (if out-blocked? @@ -520,14 +532,16 @@ (lambda (x) 0))) (do-read buffer)))] [(= err SSL_ERROR_WANT_WRITE) - (set! must-read-len len) + (when enforce-retry? + (set! must-read-len len)) (if (pump-output-once mzssl #f #f) (do-read buffer) (begin - (set-mzssl-must-read! mzssl (make-semaphore)) + (when enforce-retry? + (set-mzssl-must-read! mzssl (make-semaphore))) (wrap-evt (mzssl-o mzssl) (lambda (x) 0))))] [else - (set! must-read-len #f) + (set! must-read-len #f) ((mzssl-error mzssl) 'read-bytes "SSL read failed ~a" (get-error-message (ERR_get_error)))]))))))] @@ -662,11 +676,13 @@ (let ([err (SSL_get_error (mzssl-ssl mzssl) n)]) (cond [(= err SSL_ERROR_WANT_READ) - (set! must-write-len len) + (when enforce-retry? + (set! must-write-len len)) (let ([n (pump-input-once mzssl #f)]) (if (eq? n 0) (begin - (set-mzssl-must-write! mzssl (make-semaphore)) + (when enforce-retry? + (set-mzssl-must-write! mzssl (make-semaphore))) (wrap-evt (choice-evt (mzssl-i mzssl) (if out-blocked? @@ -675,11 +691,13 @@ (lambda (x) #f))) (do-write len non-block? enable-break?)))] [(= err SSL_ERROR_WANT_WRITE) - (set! must-write-len len) + (when enforce-retry? + (set! must-write-len len)) (if (pump-output-once mzssl #f #f) (do-write len non-block? enable-break?) (begin - (set-mzssl-must-write! mzssl (make-semaphore)) + (when enforce-retry? + (set-mzssl-must-write! mzssl (make-semaphore))) (wrap-evt (mzssl-o mzssl) (lambda (x) #f))))] [else (set! must-write-len #f) @@ -796,14 +814,13 @@ [() buffer-mode] [(mode) (set! buffer-mode mode)])))) - (define/kw (ports->ssl-ports i o - #:key - [context #f] - [encrypt default-encrypt] - [mode 'connect] - [close-original? #f] - [shutdown-on-close? #f] - [error/ssl error]) + (define (ports->ssl-ports i o + #:context [context #f] + #:encrypt [encrypt default-encrypt] + #:mode [mode 'connect] + #:close-original? [close-original? #f] + #:shutdown-on-close? [shutdown-on-close? #f] + #:error/ssl [error/ssl error]) (wrap-ports 'port->ssl-ports i o (or context encrypt) mode close-original? shutdown-on-close? error/ssl)) (define (create-ssl who context-or-encrypt-method connect/accept error/ssl) @@ -861,7 +878,7 @@ ;; Return SSL and the cancel boxL: (values ssl cancel r-bio w-bio connect?))))))))) - (define/kw (wrap-ports who i o context-or-encrypt-method connect/accept close? shutdown-on-close? error/ssl) + (define (wrap-ports who i o context-or-encrypt-method connect/accept close? shutdown-on-close? error/ssl) (unless (input-port? i) (raise-type-error who "input port" i)) (unless (output-port? o) @@ -908,14 +925,14 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SSL port registry - (define ssl-ports (make-hash-table 'weak)) + (define ssl-ports (make-weak-hasheq)) (define (register port mzssl input?) - (hash-table-put! ssl-ports port (make-ephemeron port (cons mzssl input?))) + (hash-set! ssl-ports port (make-ephemeron port (cons mzssl input?))) port) (define (lookup who what port) - (let ([v (hash-table-get ssl-ports port (lambda () #f))]) + (let ([v (hash-ref ssl-ports port #f)]) (unless v (raise-type-error who what port)) (let ([p (ephemeron-value v)]) @@ -936,9 +953,9 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SSL listen - (define/kw (ssl-listen port-k - #:optional [queue-k 5] [reuse? #f] [hostname-or-#f #f] - [protocol-symbol-or-context default-encrypt]) + (define (ssl-listen port-k + [queue-k 5] [reuse? #f] [hostname-or-#f #f] + [protocol-symbol-or-context default-encrypt]) (let ([ctx (if (ssl-server-context? protocol-symbol-or-context) protocol-symbol-or-context (make-context 'ssl-listen protocol-symbol-or-context @@ -986,18 +1003,18 @@ (raise exn))]) (wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network)))) - (define/kw (ssl-connect + (define (ssl-connect hostname port-k - #:optional [client-context-or-protocol-symbol default-encrypt]) + [client-context-or-protocol-symbol default-encrypt]) (do-ssl-connect 'ssl-connect tcp-connect hostname port-k client-context-or-protocol-symbol)) - (define/kw (ssl-connect/enable-break - hostname port-k - #:optional [client-context-or-protocol-symbol default-encrypt]) + (define (ssl-connect/enable-break + hostname port-k + [client-context-or-protocol-symbol default-encrypt]) (do-ssl-connect 'ssl-connect/enable-break tcp-connect/enable-break hostname diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl index 49166ece87..e36ea3de8d 100644 --- a/collects/openssl/openssl.scrbl +++ b/collects/openssl/openssl.scrbl @@ -67,6 +67,9 @@ details (including the meanings of the protocol symbols). Closing the resulting output port does not send a shutdown message to the server. See also @scheme[ports->ssl-ports]. +@;{ +See `enforce-retry?' in "mzssl.ss", currently set to #f so that this +paragraph does not apply: Beware that the SSL protocol allows reading or writing in only one direction at a time. If you request data from the input port, then data cannot be written to the output port (i.e., attempting to write @@ -76,15 +79,17 @@ read. Even merely checking for input data --- using reading, and the other end must respond with a (possibly zero-length) answer. Protocols that work with SSL, such as IMAP, have a well-defined communication pattern, where theres no question of -whether the other end is supposed to be sending or reading data.} +whether the other end is supposed to be sending or reading data. +} +} @defproc[(ssl-connect/enable-break (hostname string?) (port-no (integer-in 1 65535)) (client-protocol (or/c ssl-client-context? symbol?) 'sslv2-or-v3)) - (values input-port? output-port?)])]{ + (values input-port? output-port?)]{ Like @scheme[ssl-connect], but breaking is enabled while trying to connect.} @@ -224,12 +229,11 @@ protocol symbols). This argument is ignored if a @scheme[context] argument is supplied. If @scheme[close-original?] is true, then when both SSL ports are -closed, the given input and output ports are automatically closed. The -default is #f. +closed, the given input and output ports are automatically closed. If @scheme[shutdown-on-close?] is true, then when the output SSL port is closed, it sends a shutdown message to the other end of the SSL -connection. The default is #f. When shutdown is enabled, closing the +connection. When shutdown is enabled, closing the output port can fail if the given output port becomes unwritable (e.g., because the other end of the given port has been closed by another process). @@ -281,8 +285,7 @@ the client or server. If @scheme[rsa?] is @scheme[#t] (the default), the first RSA key is read (i.e., non-RSA keys are skipped). If @scheme[asn1?] is -@scheme[#t] (the default is @scheme[#f]), the file is parsed as ASN1 -format instead of PEM. +@scheme[#t], the file is parsed as ASN1 format instead of PEM. You can use the file @filepath{test.pem} of the @filepath{openssl} collection for testing purposes. Since @filepath{test.pem} is public,