Fix bugs in port-closure-detection logic.
To begin with, I was looking at closure of the wrong port. Fixing that, however, still left me with the problem that there was no event for closure of the downstream port that I could use, so the input-cooker has to poll to see if downstream has indicated that it should be shut down. Finally, the actual port-closing code was doing different things in different cases, so I've straightened that out as well, and there was a race between closing raw-out in the output-cooker and writing some feedback to it in the input-cooker, so I've added a with-handlers to ignore write errors in the input-cooker.
This commit is contained in:
parent
cf7563e5ed
commit
0c05a400f8
|
@ -43,32 +43,40 @@
|
||||||
|
|
||||||
(define (cook-io raw-in raw-out prompt)
|
(define (cook-io raw-in raw-out prompt)
|
||||||
(define-values (cooked-in cooked-out) (make-pipe))
|
(define-values (cooked-in cooked-out) (make-pipe))
|
||||||
|
(define (close-ports)
|
||||||
|
(close-output-port cooked-out) ;; signal to our reader that we're not sending more
|
||||||
|
(close-input-port raw-in)) ;; signal to upstream that we are done reading
|
||||||
(thread
|
(thread
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(define input-buffer (make-bytes 4096))
|
(define input-buffer (make-bytes 4096))
|
||||||
(let loop ((b (buffer '() #f)))
|
(let loop ((b (buffer '() #f)))
|
||||||
(if (port-closed? cooked-out)
|
(if (port-closed? cooked-in)
|
||||||
;; our job here is
|
;; The ultimate reader of our cooked output has closed
|
||||||
'done
|
;; their input port. We are therefore done.
|
||||||
(let ((count (read-bytes-avail! input-buffer raw-in)))
|
(close-ports)
|
||||||
(if (eof-object? count)
|
;; TODO: remove polling for port-closed when we get port-closed-evt
|
||||||
(begin (close-output-port cooked-out)
|
(let ((count (sync/timeout 0.5 (read-bytes-avail!-evt input-buffer raw-in))))
|
||||||
(loop b))
|
(cond
|
||||||
(let process-bytes ((i 0) (b b))
|
((eof-object? count) ;; end-of-file on input
|
||||||
(if (>= i count)
|
(close-ports))
|
||||||
(loop b)
|
((eq? count #f) ;; timeout - poll to see if cooked-out has been closed
|
||||||
(update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
|
(loop b))
|
||||||
(lambda ()
|
(else ;; a number - count of bytes read
|
||||||
(close-output-port cooked-out)
|
(let process-bytes ((i 0) (b b))
|
||||||
(close-input-port raw-in))
|
(if (>= i count)
|
||||||
(lambda (line new-b)
|
(loop b)
|
||||||
(write-string "\r\n" raw-out)
|
(update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
|
||||||
(write-string line cooked-out)
|
close-ports
|
||||||
(newline cooked-out)
|
(lambda (line new-b)
|
||||||
(process-bytes (+ i 1) new-b))
|
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
||||||
(lambda (new-b feedback)
|
(write-string "\r\n" raw-out))
|
||||||
(write-string feedback raw-out)
|
(write-string line cooked-out)
|
||||||
(process-bytes (+ i 1) new-b)))))))))))
|
(newline cooked-out)
|
||||||
|
(process-bytes (+ i 1) new-b))
|
||||||
|
(lambda (new-b feedback)
|
||||||
|
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
||||||
|
(write-string feedback raw-out))
|
||||||
|
(process-bytes (+ i 1) new-b))))))))))))
|
||||||
(values cooked-in (cook-output raw-out)))
|
(values cooked-in (cook-output raw-out)))
|
||||||
|
|
||||||
(define (cook-output raw-out)
|
(define (cook-output raw-out)
|
||||||
|
|
|
@ -52,7 +52,11 @@
|
||||||
(define finished-writing? (port-closed? out))
|
(define finished-writing? (port-closed? out))
|
||||||
(if (and finished-reading? finished-writing?)
|
(if (and finished-reading? finished-writing?)
|
||||||
'closed
|
'closed
|
||||||
(sync (if (queue-empty? oob-queue)
|
(sync (handle-evt (alarm-evt (+ (current-inexact-milliseconds) 500))
|
||||||
|
;; TODO: remove polling for port-closed when we get port-closed-evt
|
||||||
|
(lambda (dummy)
|
||||||
|
(loop oob-queue remaining-credit)))
|
||||||
|
(if (queue-empty? oob-queue)
|
||||||
never-evt
|
never-evt
|
||||||
(let-values (((first rest) (dequeue oob-queue)))
|
(let-values (((first rest) (dequeue oob-queue)))
|
||||||
(handle-evt (channel-put-evt oob-ch first)
|
(handle-evt (channel-put-evt oob-ch first)
|
||||||
|
|
Loading…
Reference in New Issue