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

more thoroughly convert the SSL machinery to use a connection-specific error function

Browse Source 
svn: r4626
This commit is contained in:
Matthew Flatt 2006-10-18 05:46:14 +00:00
parent 2ccf88b6db
commit c18ca621a3
2 changed files with 39 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/openssl/doc.txt
View File

@ -142,7 +142,8 @@ otherwise.
[#:context context] [#:context context]
[#:encrypt protocol-symbol] [#:encrypt protocol-symbol]
[#:close-original? close?] [#:close-original? close?]
[#:shutdown-on-close? shutdown?]) [#:shutdown-on-close? shutdown?]
[#:error/ssl error])
Returns two values --- an input port and an output port --- that Returns two values --- an input port and an output port --- that
implement the SSL protocol over the given input and output port. (The implement the SSL protocol over the given input and output port. (The
@ -174,6 +175,11 @@ default is #f. When shutdown is enabled, closing the output port can
fail if the given output port becomes unwritable (e.g., because the fail if the given output port becomes unwritable (e.g., because the
other end of the given port has been closed by another process). other end of the given port has been closed by another process).
The `error' argument is an error procedure to use for raising
communication errors. The default is `error', which raises `exn:fail';
in contrast, `ssl-accept' and `ssl-connect' use an error function that
raises `exn:fail:network'.
-- Context procedures -------------------------------------------- -- Context procedures --------------------------------------------

58
collects/openssl/mzssl.ss
View File

@ -263,7 +263,8 @@
flushing? must-write must-read flushing? must-write must-read
refcount refcount
close-original? shutdown-on-close? close-original? shutdown-on-close?
finalizer-cancel)) finalizer-cancel
error))
(define (make-immobile-bytes n) (define (make-immobile-bytes n)
(if 3m? (if 3m?
@ -428,7 +429,7 @@
[else [else
(let ([m (BIO_write r-bio buffer n)]) (let ([m (BIO_write r-bio buffer n)])
(unless (= m n) (unless (= m n)
(error 'pump-input-once "couldn't write all bytes to BIO!")) ((mzssl-error mzssl) 'pump-input-once "couldn't write all bytes to BIO!"))
m)])))) m)]))))
(define (pump-output-once mzssl need-progress? output-blocked-result) (define (pump-output-once mzssl need-progress? output-blocked-result)
@ -443,7 +444,7 @@
(if (n . <= . 0) (if (n . <= . 0)
(begin (begin
(when need-progress? (when need-progress?
(error 'pump-output-once "no output to pump!")) ((mzssl-error mzssl) 'pump-output-once "no output to pump!"))
#f) #f)
(begin (begin
(write-bytes buffer pipe-w 0 n) (write-bytes buffer pipe-w 0 n)
@ -523,8 +524,9 @@
(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)
(error 'read-bytes "SSL read failed ~a" ((mzssl-error mzssl) 'read-bytes
(get-error-message (ERR_get_error)))]))))))] "SSL read failed ~a"
(get-error-message (ERR_get_error)))]))))))]
[top-read [top-read
(lambda (buffer) (lambda (buffer)
(cond (cond
@ -677,8 +679,9 @@
(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)
(error 'write-bytes "SSL write failed ~a" ((mzssl-error mzssl) 'write-bytes
(get-error-message (ERR_get_error)))])))))))] "SSL write failed ~a"
(get-error-message (ERR_get_error)))])))))))]
[top-write [top-write
(lambda (buffer s e non-block? enable-break?) (lambda (buffer s e non-block? enable-break?)
(cond (cond
@ -708,10 +711,10 @@
(unless (and (len . >= . must-write-len) (unless (and (len . >= . must-write-len)
(bytes=? (subbytes xfer-buffer 0 must-write-len) (bytes=? (subbytes xfer-buffer 0 must-write-len)
(subbytes buffer s (+ s must-write-len)))) (subbytes buffer s (+ s must-write-len))))
(error 'write-bytes ((mzssl-error mzssl) 'write-bytes
"SSL output request: ~e different from previous unsatisfied request: ~e" "SSL output request: ~e different from previous unsatisfied request: ~e"
(subbytes buffer s e) (subbytes buffer s e)
(subbytes xfer-buffer 0 must-write-len))) (subbytes xfer-buffer 0 must-write-len)))
(do-write must-write-len non-block? enable-break?)) (do-write must-write-len non-block? enable-break?))
;; No previous write obligation: ;; No previous write obligation:
(begin (begin
@ -762,8 +765,9 @@
;; out that we have and try again, up to 10 times. ;; out that we have and try again, up to 10 times.
(unless (cnt . >= . 10) (unless (cnt . >= . 10)
(loop (add1 cnt))) (loop (add1 cnt)))
(error 'read-bytes "SSL shutdown failed ~a" ((mzssl-error mzssl) 'read-bytes
(get-error-message (ERR_get_error))))]))))))) "SSL shutdown failed ~a"
(get-error-message (ERR_get_error))))])))))))
(set-mzssl-w-closed?! mzssl #t) (set-mzssl-w-closed?! mzssl #t)
(mzssl-release mzssl) (mzssl-release mzssl)
#f]))] #f]))]
@ -794,10 +798,11 @@
[encrypt default-encrypt] [encrypt default-encrypt]
[mode 'connect] [mode 'connect]
[close-original? #f] [close-original? #f]
[shutdown-on-close? #f]) [shutdown-on-close? #f]
(wrap-ports 'port->ssl-ports i o (or context encrypt) mode close-original? shutdown-on-close?)) [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) (define (create-ssl who context-or-encrypt-method connect/accept error/ssl)
(atomically ; so we register the finalizer (and it's ok since everything is non-blocking) (atomically ; so we register the finalizer (and it's ok since everything is non-blocking)
(let ([ctx (get-context who context-or-encrypt-method (eq? connect/accept 'connect))]) (let ([ctx (get-context who context-or-encrypt-method (eq? connect/accept 'connect))])
(check-valid ctx who "context creation") (check-valid ctx who "context creation")
@ -852,14 +857,14 @@
;; 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 (wrap-ports who i o context-or-encrypt-method connect/accept close? shutdown-on-close?) (define/kw (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)
(raise-type-error who "output port" o)) (raise-type-error who "output port" o))
;; Create the SSL connection: ;; Create the SSL connection:
(let-values ([(ssl cancel r-bio w-bio connect?) (let-values ([(ssl cancel r-bio w-bio connect?)
(create-ssl who context-or-encrypt-method connect/accept)]) (create-ssl who context-or-encrypt-method connect/accept error/ssl)])
;; connect/accept: ;; connect/accept:
(let-values ([(buffer) (make-bytes BUFFER-SIZE)] (let-values ([(buffer) (make-bytes BUFFER-SIZE)]
[(pipe-r pipe-w) (make-pipe)] [(pipe-r pipe-w) (make-pipe)]
@ -869,7 +874,8 @@
#f #f #f #f
#f #f #f 2 #f #f #f 2
close? shutdown-on-close? close? shutdown-on-close?
cancel)]) cancel
error/ssl)])
(let loop () (let loop ()
(let ([status (if connect? (let ([status (if connect?
(SSL_connect ssl) (SSL_connect ssl)
@ -881,16 +887,16 @@
[(= err SSL_ERROR_WANT_READ) [(= err SSL_ERROR_WANT_READ)
(let ([n (pump-input-once mzssl (if out-blocked? o #t))]) (let ([n (pump-input-once mzssl (if out-blocked? o #t))])
(when (eof-object? n) (when (eof-object? n)
(error/network who "~a failed (input terminated prematurely)" (error/ssl who "~a failed (input terminated prematurely)"
(if connect? "connect" "accept")))) (if connect? "connect" "accept"))))
(loop)] (loop)]
[(= err SSL_ERROR_WANT_WRITE) [(= err SSL_ERROR_WANT_WRITE)
(pump-output-once mzssl #t #f) (pump-output-once mzssl #t #f)
(loop)] (loop)]
[else [else
(error/network who "~a failed ~a" (error/ssl who "~a failed ~a"
(if connect? "connect" "accept") (if connect? "connect" "accept")
(get-error-message (ERR_get_error)))])))))) (get-error-message (ERR_get_error)))]))))))
;; Connection complete; make ports ;; Connection complete; make ports
(values (register (make-ssl-input-port mzssl) mzssl #t) (values (register (make-ssl-input-port mzssl) mzssl #t)
(register (make-ssl-output-port mzssl) mzssl #f)))))) (register (make-ssl-output-port mzssl) mzssl #f))))))
@ -956,7 +962,7 @@
(close-input-port i) (close-input-port i)
(close-output-port o) (close-output-port o)
(raise exn))]) (raise exn))])
(wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f)))) (wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f error/network))))
(define (ssl-accept ssl-listener) (define (ssl-accept ssl-listener)
(do-ssl-accept 'ssl-accept tcp-accept ssl-listener)) (do-ssl-accept 'ssl-accept tcp-accept ssl-listener))
@ -974,7 +980,7 @@
(close-input-port i) (close-input-port i)
(close-output-port o) (close-output-port o)
(raise exn))]) (raise exn))])
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f)))) (wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network))))
(define/kw (ssl-connect (define/kw (ssl-connect
hostname port-k hostname port-k