scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
ftpd.scm
View File

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