suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove openssl constraint that attempting to read must lead to an actual read

Browse Source 
svn: r14390
This commit is contained in:
Matthew Flatt 2009-03-31 19:35:08 +00:00
parent 21b2e76489
commit 2eb5fb2a55
2 changed files with 71 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
collects/openssl/mzssl.ss
View File

@ -1,7 +1,8 @@
;; Warn clients: when a (non-blocking) write fails to write all the ;; Disabled when `enforce-retry?' is #f:
;; data, the stream is actually committed to writing the given data ;; Warn clients: when a (non-blocking) write fails to write all the
;; in the future. (This requirement comes from the SSL library.) ;; 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 ;; Another warning: data that is written and not buffered may still be
;; in flight between MzScheme and the underlying ports. A `flush-output' ;; 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 ;; read/write (the opposite direction) didn't finish, and so that
;; opposite must be completed, first. ;; opposite must be completed, first.
(module mzssl mzscheme (module mzssl scheme
(require mzlib/foreign (require mzlib/foreign
mzlib/port mzlib/port
mzlib/kw
mzlib/runtime-path) mzlib/runtime-path)
(provide ssl-available? (provide ssl-available?
@ -176,6 +176,7 @@
(define SSL_VERIFY_FAIL_IF_NO_PEER_CERT #x02) (define SSL_VERIFY_FAIL_IF_NO_PEER_CERT #x02)
(define SSL_MODE_ENABLE_PARTIAL_WRITE #x01) (define SSL_MODE_ENABLE_PARTIAL_WRITE #x01)
(define SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER #x02)
(define SSL_CTRL_MODE 33) (define SSL_CTRL_MODE 33)
(define-mzscheme scheme_start_atomic (-> _void)) (define-mzscheme scheme_start_atomic (-> _void))
@ -186,6 +187,15 @@
;; 4096 of unencrypted data ;; 4096 of unencrypted data
(define BUFFER-SIZE 8000) (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 ;; Error handling
@ -268,7 +278,8 @@
refcount refcount
close-original? shutdown-on-close? close-original? shutdown-on-close?
finalizer-cancel finalizer-cancel
error)) error)
#:mutable)
(define (make-immobile-bytes n) (define (make-immobile-bytes n)
(if 3m? (if 3m?
@ -312,16 +323,15 @@
(atomically ; so we reliably register the finalizer (atomically ; so we reliably register the finalizer
(let ([ctx (SSL_CTX_new meth)]) (let ([ctx (SSL_CTX_new meth)])
(check-valid ctx who "context creation") (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))) (register-finalizer ctx (lambda (v) (SSL_CTX_free v)))
((if client? make-ssl-client-context make-ssl-server-context) ctx))))) ((if client? make-ssl-client-context make-ssl-server-context) ctx)))))
(define/kw (ssl-make-client-context (define (ssl-make-client-context [protocol-symbol default-encrypt])
#:optional [protocol-symbol default-encrypt])
(make-context 'ssl-make-client-context protocol-symbol "" #t)) (make-context 'ssl-make-client-context protocol-symbol "" #t))
(define/kw (ssl-make-server-context (define (ssl-make-server-context [protocol-symbol default-encrypt])
#:optional [protocol-symbol default-encrypt])
(make-context 'ssl-make-server-context protocol-symbol "" #f)) (make-context 'ssl-make-server-context protocol-symbol "" #f))
(define (get-context who context-or-encrypt-method client?) (define (get-context who context-or-encrypt-method client?)
@ -350,7 +360,7 @@
"path or string" "path or string"
pathname)) pathname))
(let ([path (path->bytes (let ([path (path->bytes
(path->complete-path (expand-path pathname) (path->complete-path (cleanse-path pathname)
(current-directory)))]) (current-directory)))])
(let ([n (load-it ctx path)]) (let ([n (load-it ctx path)])
(unless (= n 1) (unless (= n 1)
@ -379,8 +389,8 @@
1)))) 1))))
ssl-listener pathname)) ssl-listener pathname))
(define/kw (ssl-load-private-key! ssl-context-or-listener pathname (define (ssl-load-private-key! ssl-context-or-listener pathname
#:optional [rsa? #t] [asn1? #f]) [rsa? #t] [asn1? #f])
(ssl-load-... (ssl-load-...
'ssl-load-private-key! 'ssl-load-private-key!
(lambda (ctx path) (lambda (ctx path)
@ -491,7 +501,7 @@
(set! must-read-len #f) (set! must-read-len #f)
(if must-read-len (if must-read-len
;; If we were forced to try to read a certain amount, ;; 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. ;; request.
(let ([orig-n (bytes-length buffer)]) (let ([orig-n (bytes-length buffer)])
(bytes-copy! buffer 0 xfer-buffer 0 (min n orig-n)) (bytes-copy! buffer 0 xfer-buffer 0 (min n orig-n))
@ -507,11 +517,13 @@
(set! must-read-len #f) (set! must-read-len #f)
eof] eof]
[(= err SSL_ERROR_WANT_READ) [(= 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)]) (let ([n (pump-input-once mzssl #f)])
(if (eq? n 0) (if (eq? n 0)
(begin (begin
(set-mzssl-must-read! mzssl (make-semaphore)) (when enforce-retry?
(set-mzssl-must-read! mzssl (make-semaphore)))
(wrap-evt (choice-evt (wrap-evt (choice-evt
(mzssl-i mzssl) (mzssl-i mzssl)
(if out-blocked? (if out-blocked?
@ -520,14 +532,16 @@
(lambda (x) 0))) (lambda (x) 0)))
(do-read buffer)))] (do-read buffer)))]
[(= err SSL_ERROR_WANT_WRITE) [(= 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) (if (pump-output-once mzssl #f #f)
(do-read buffer) (do-read buffer)
(begin (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))))] (wrap-evt (mzssl-o mzssl) (lambda (x) 0))))]
[else [else
(set! must-read-len #f) (set! must-read-len #f)
((mzssl-error mzssl) 'read-bytes ((mzssl-error mzssl) 'read-bytes
"SSL read failed ~a" "SSL read failed ~a"
(get-error-message (ERR_get_error)))]))))))] (get-error-message (ERR_get_error)))]))))))]
@ -662,11 +676,13 @@
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)]) (let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
(cond (cond
[(= err SSL_ERROR_WANT_READ) [(= 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)]) (let ([n (pump-input-once mzssl #f)])
(if (eq? n 0) (if (eq? n 0)
(begin (begin
(set-mzssl-must-write! mzssl (make-semaphore)) (when enforce-retry?
(set-mzssl-must-write! mzssl (make-semaphore)))
(wrap-evt (choice-evt (wrap-evt (choice-evt
(mzssl-i mzssl) (mzssl-i mzssl)
(if out-blocked? (if out-blocked?
@ -675,11 +691,13 @@
(lambda (x) #f))) (lambda (x) #f)))
(do-write len non-block? enable-break?)))] (do-write len non-block? enable-break?)))]
[(= err SSL_ERROR_WANT_WRITE) [(= 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) (if (pump-output-once mzssl #f #f)
(do-write len non-block? enable-break?) (do-write len non-block? enable-break?)
(begin (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))))] (wrap-evt (mzssl-o mzssl) (lambda (x) #f))))]
[else [else
(set! must-write-len #f) (set! must-write-len #f)
@ -796,14 +814,13 @@
[() buffer-mode] [() buffer-mode]
[(mode) (set! buffer-mode mode)])))) [(mode) (set! buffer-mode mode)]))))
(define/kw (ports->ssl-ports i o (define (ports->ssl-ports i o
#:key #:context [context #f]
[context #f] #:encrypt [encrypt default-encrypt]
[encrypt default-encrypt] #:mode [mode 'connect]
[mode 'connect] #:close-original? [close-original? #f]
[close-original? #f] #:shutdown-on-close? [shutdown-on-close? #f]
[shutdown-on-close? #f] #:error/ssl [error/ssl error])
[error/ssl error])
(wrap-ports 'port->ssl-ports i o (or context encrypt) mode close-original? shutdown-on-close? error/ssl)) (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) (define (create-ssl who context-or-encrypt-method connect/accept error/ssl)
@ -861,7 +878,7 @@
;; Return SSL and the cancel boxL: ;; Return SSL and the cancel boxL:
(values ssl cancel r-bio w-bio connect?))))))))) (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) (unless (input-port? i)
(raise-type-error who "input port" i)) (raise-type-error who "input port" i))
(unless (output-port? o) (unless (output-port? o)
@ -908,14 +925,14 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL port registry ;; SSL port registry
(define ssl-ports (make-hash-table 'weak)) (define ssl-ports (make-weak-hasheq))
(define (register port mzssl input?) (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) port)
(define (lookup who what 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 (unless v
(raise-type-error who what port)) (raise-type-error who what port))
(let ([p (ephemeron-value v)]) (let ([p (ephemeron-value v)])
@ -936,9 +953,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL listen ;; SSL listen
(define/kw (ssl-listen port-k (define (ssl-listen port-k
#:optional [queue-k 5] [reuse? #f] [hostname-or-#f #f] [queue-k 5] [reuse? #f] [hostname-or-#f #f]
[protocol-symbol-or-context default-encrypt]) [protocol-symbol-or-context default-encrypt])
(let ([ctx (if (ssl-server-context? protocol-symbol-or-context) (let ([ctx (if (ssl-server-context? protocol-symbol-or-context)
protocol-symbol-or-context protocol-symbol-or-context
(make-context 'ssl-listen protocol-symbol-or-context (make-context 'ssl-listen protocol-symbol-or-context
@ -986,18 +1003,18 @@
(raise exn))]) (raise exn))])
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network)))) (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 hostname port-k
#:optional [client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect (do-ssl-connect 'ssl-connect
tcp-connect tcp-connect
hostname hostname
port-k port-k
client-context-or-protocol-symbol)) client-context-or-protocol-symbol))
(define/kw (ssl-connect/enable-break (define (ssl-connect/enable-break
hostname port-k hostname port-k
#:optional [client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect/enable-break (do-ssl-connect 'ssl-connect/enable-break
tcp-connect/enable-break tcp-connect/enable-break
hostname hostname

17
collects/openssl/openssl.scrbl
View File

@ -67,6 +67,9 @@ details (including the meanings of the protocol symbols).
Closing the resulting output port does not send a shutdown message to Closing the resulting output port does not send a shutdown message to
the server. See also @scheme[ports->ssl-ports]. 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 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 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 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) reading, and the other end must respond with a (possibly zero-length)
answer. Protocols that work with SSL, such as IMAP, have a answer. Protocols that work with SSL, such as IMAP, have a
well-defined communication pattern, where theres no question of 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 @defproc[(ssl-connect/enable-break
(hostname string?) (hostname string?)
(port-no (integer-in 1 65535)) (port-no (integer-in 1 65535))
(client-protocol (client-protocol
(or/c ssl-client-context? symbol?) 'sslv2-or-v3)) (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 Like @scheme[ssl-connect], but breaking is enabled while trying to
connect.} connect.}
@ -224,12 +229,11 @@ protocol symbols). This argument is ignored if a @scheme[context]
argument is supplied. argument is supplied.
If @scheme[close-original?] is true, then when both SSL ports are If @scheme[close-original?] is true, then when both SSL ports are
closed, the given input and output ports are automatically closed. The closed, the given input and output ports are automatically closed.
default is #f.
If @scheme[shutdown-on-close?] is true, then when the output SSL port 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 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 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 (e.g., because the other end of the given port has been closed by
another process). another process).
@ -281,8 +285,7 @@ the client or server.
If @scheme[rsa?] is @scheme[#t] (the default), the first RSA key is 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 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 @scheme[#t], the file is parsed as ASN1 format instead of PEM.
format instead of PEM.
You can use the file @filepath{test.pem} of the @filepath{openssl} You can use the file @filepath{test.pem} of the @filepath{openssl}
collection for testing purposes. Since @filepath{test.pem} is public, collection for testing purposes. Since @filepath{test.pem} is public,