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

avoid race condition on close

Browse Source 
svn: r2812
This commit is contained in:
Matthew Flatt 2006-04-27 13:01:46 +00:00
parent 1d035f5d2b
commit dba987383b
1 changed files with 46 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/openssl/mzssl.ss
View File

@ -289,6 +289,7 @@
;; internal: ;; internal:
(define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w (define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w
buffer lock buffer lock
w-closed? r-closed?
flushing? must-write must-read flushing? must-write must-read
refcount refcount
close-original? shutdown-on-close? close-original? shutdown-on-close?
@ -567,6 +568,8 @@
[(mzssl-must-write mzssl) [(mzssl-must-write mzssl)
=> (lambda (sema) => (lambda (sema)
(wrap-evt (semaphore-peek-evt sema) (lambda (x) 0)))] (wrap-evt (semaphore-peek-evt sema) (lambda (x) 0)))]
[(mzssl-r-closed? mzssl)
0]
[else [else
(let ([sema (mzssl-must-read mzssl)]) (let ([sema (mzssl-must-read mzssl)])
(when sema (when sema
@ -595,7 +598,9 @@
(call-with-semaphore (call-with-semaphore
(mzssl-lock mzssl) (mzssl-lock mzssl)
(lambda () (lambda ()
(mzssl-release mzssl))))))) (unless (mzssl-r-closed? mzssl)
(set-mzssl-r-closed?! mzssl #t)
(mzssl-release mzssl))))))))
(define (flush-ssl mzssl enable-break?) (define (flush-ssl mzssl enable-break?)
;; Make sure that this SSL connection has said everything that it ;; Make sure that this SSL connection has said everything that it
@ -676,13 +681,10 @@
;; to flush from SSL to the underlying ports: ;; to flush from SSL to the underlying ports:
(set-mzssl-flushing?! mzssl (make-semaphore)) (set-mzssl-flushing?! mzssl (make-semaphore))
(channel-put flush-ch #t)] (channel-put flush-ch #t)]
[(eq? buffer-mode 'block)
;; Otherwise, we could have buffered it, so it might as
;; well sit between SSL and the underlying ports.
(void)]
[else [else
;; Since we're allowed to block but not buffer, try to ;; We're allowed to block, and things seem to
;; flush all the way through: ;; work better if we, try to flush all the way
;; through (even though we're allowed to buffer):
(flush-ssl mzssl enable-break?)]) (flush-ssl mzssl enable-break?)])
n) n)
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)]) (let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
@ -721,6 +723,8 @@
(list (semaphore-peek-evt (mzssl-flushing? mzssl))) (list (semaphore-peek-evt (mzssl-flushing? mzssl)))
;; Try again later: ;; Try again later:
(wrap-evt always-evt (lambda (v) #f)))] (wrap-evt always-evt (lambda (v) #f)))]
[(mzssl-w-closed? mzssl)
#f]
[(mzssl-must-read mzssl) [(mzssl-must-read mzssl)
;; Read pending, so wait until it's done: ;; Read pending, so wait until it's done:
=> (lambda (sema) => (lambda (sema)
@ -765,10 +769,13 @@
;; close proc: ;; close proc:
(letrec ([do-close (letrec ([do-close
(lambda () (lambda ()
(if (mzssl-flushing? mzssl) (cond
(semaphore-peek-evt (mzssl-flushing? mzssl)) [(mzssl-flushing? mzssl)
(semaphore-peek-evt (mzssl-flushing? mzssl))]
[(mzssl-w-closed? mzssl)
#f]
[else
;; issue shutdown (i.e., EOF on read end) ;; issue shutdown (i.e., EOF on read end)
(begin
(when (mzssl-shutdown-on-close? mzssl) (when (mzssl-shutdown-on-close? mzssl)
(let loop ([cnt 0]) (let loop ([cnt 0])
(let ([out-blocked? (flush-ssl mzssl #f)]) (let ([out-blocked? (flush-ssl mzssl #f)])
@ -791,8 +798,9 @@
(loop (add1 cnt))) (loop (add1 cnt)))
(error 'read-bytes "SSL shutdown failed ~a" (error 'read-bytes "SSL shutdown failed ~a"
(get-error-message (ERR_get_error))))]))))))) (get-error-message (ERR_get_error))))])))))))
(set-mzssl-w-closed?! mzssl #t)
(mzssl-release mzssl) (mzssl-release mzssl)
#f)))] #f]))]
[close-loop [close-loop
(lambda () (lambda ()
(let ([v (call-with-semaphore (let ([v (call-with-semaphore
@ -891,7 +899,9 @@
[(pipe-r pipe-w) (make-pipe)] [(pipe-r pipe-w) (make-pipe)]
[(cancel) (box #t)]) [(cancel) (box #t)])
(let ([mzssl (make-mzssl ssl i o r-bio w-bio pipe-r pipe-w (let ([mzssl (make-mzssl ssl i o r-bio w-bio pipe-r pipe-w
buffer (make-semaphore 1) #f #f #f 2 buffer (make-semaphore 1)
#f #f
#f #f #f 2
close? shutdown-on-close? close? shutdown-on-close?
cancel)]) cancel)])
(let loop () (let loop ()