Handle quit more correctly:

Previously, it tried to write a final reply even into a socket which
had been shut down from the other end.  This would terminate the
connection thread and prevent a regular close.

So we introduce an IRREGULAR-QUIT condition for this purpose and guard against EOF better.

Also, revert to not using INTERNET-HOST-ADDRESS-TO-BYTES.
This commit is contained in:
sperber 2001-06-20 09:02:22 +00:00
parent 92b47b6487
commit b99348651d
1 changed files with 42 additions and 30 deletions

View File

@ -80,16 +80,16 @@
(socket:outport socket))
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((= errno errno/notconn)
(exit 'fick-dich-ins-knie))))
(lambda ()
(shutdown-socket socket shutdown/sends+receives)
(close-socket socket))))))))
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((= errno errno/notconn)
(exit 'fick-dich-ins-knie))))
(lambda ()
(shutdown-socket socket shutdown/sends+receives)))))
(close-socket socket))))
port)))
@ -128,21 +128,31 @@
(define-condition-type 'ftpd-quit '())
(define ftpd-quit? (condition-predicate 'ftpd-quit))
(define-condition-type 'ftpd-irregular-quit '())
(define ftpd-irregular-quit? (condition-predicate 'ftpd-irregular-quit))
(define-condition-type 'ftpd-error '())
(define ftpd-error? (condition-predicate 'ftpd-error))
(define (handle-commands)
(with-handler
(lambda (condition more)
;; this in really only for ftpd-quit
(write-replies)
(more))
(lambda ()
(let loop ()
(write-replies)
(accept-command)
(loop)))))
(call-with-current-continuation
(lambda (exit)
(with-handler
(lambda (condition more)
(if (ftpd-quit? condition)
(with-handler
(lambda (condition ignore)
(more))
(lambda ()
(write-replies)
(exit 'fick-dich-ins-knie)))
(more)))
(lambda ()
(let loop ()
(write-replies)
(accept-command)
(loop)))))))
(define (accept-command)
(let ((command-line (read-crlf-line-timeout (session-control-input-port)
@ -495,13 +505,15 @@
(define (this-host-address)
(car (host-info:addresses (host-info (system-name)))))
(define (format-internet-host-address address . maybe-separator)
(let ((separator (optional maybe-separator ".")))
(apply (lambda (b1 b2 b3 b4)
(string-append
b1 separator b2 separator
b3 separator b4))
(map number->string (internet-host-address-to-bytes address)))))
(define (format-internet-host-address address)
(define (extract shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))
(string-append
(extract 24) "." (extract 16) "." (extract 8) "." (extract 0)))
(define (format-port port)
(string-append
@ -715,7 +727,7 @@
(define (parse-command-line line)
(if (eof-object? line) ; Netscape does this
(values "QUIT" "")
(signal 'ftpd-irregular-quit)
(let* ((line (trim-spaces line))
(split-position (string-index line #\space)))
(if split-position
@ -795,7 +807,7 @@
; Version
(define *ftpd-version* "$Revision: 1.8 $")
(define *ftpd-version* "$Revision: 1.9 $")
(define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*)))