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

Simplify and debugify NORMALIZE-PATH. 

Catch ERRNO/NOTCONN out of SOCKET->STRING.
This commit is contained in:
sperber 2001-07-07 19:37:53 +00:00
parent dbebe4e8ef
commit 2c6d19ef63
1 changed files with 24 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
ftpd.scm
View File

@ -144,7 +144,9 @@
(cond (cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does ;; can and does
((= errno errno/notconn) ((or (= errno errno/notconn)
;; this one can come out of SOCKET->STRING
(= errno errno/inval))
(log (syslog-level warning) (log (syslog-level warning)
"socket not connected any more - exiting thread") "socket not connected any more - exiting thread")
(exit 'fick-dich-ins-knie)))) (exit 'fick-dich-ins-knie))))
@ -390,7 +392,8 @@
(log (syslog-level debug) "handling CWD-command with ~S as path-argument" (log (syslog-level debug) "handling CWD-command with ~S as path-argument"
path) path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((current-directory (assemble-path path))) (let ((current-directory (assemble-path (session-current-directory)
path)))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(log (syslog-level debug) (log (syslog-level debug)
@ -433,7 +436,8 @@
(if (string=? "" path) (if (string=? "" path)
(signal-error! 500 "No argument.")) (signal-error! 500 "No argument."))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path path)))) (assemble-path (session-current-directory)
path))))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(signal-error! 550 (signal-error! 550
@ -490,7 +494,8 @@
(if (string=? "" path) (if (string=? "" path)
(signal-error! 500 "No argument.")) (signal-error! 500 "No argument."))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path path)))) (assemble-path (session-current-directory)
path))))
(if (file-exists? full-path) (if (file-exists? full-path)
(signal-error! (signal-error!
@ -641,7 +646,9 @@
(register-reply! 227 (register-reply! 227
(format #f "Passive mode OK (~A,~A)" (format #f "Passive mode OK (~A,~A)"
(format-internet-host-address host-address ",") (format-internet-host-address
(this-host-address)
",")
(format-port port)))))))) (format-port port))))))))
(define (this-host-address) (define (this-host-address)
@ -710,7 +717,8 @@
(define (generate-listing path flags) (define (generate-listing path flags)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path path)))) (assemble-path (session-current-directory)
path))))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(signal-error! 451 (signal-error! 451
@ -737,7 +745,8 @@
(define (handle-retr path) (define (handle-retr path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path path)))) (assemble-path (session-current-directory)
path))))
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO (with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
(lambda (condition more) (lambda (condition more)
(signal-error! 550 (signal-error! 550
@ -766,7 +775,8 @@
(define (handle-stor path) (define (handle-stor path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path path)))) (assemble-path (session-current-directory)
path))))
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (condition more) (lambda (condition more)
(signal-error! 550 (signal-error! 550
@ -787,13 +797,12 @@
(socket:inport (session-data-socket)) (socket:inport (session-data-socket))
file-port))))))))))) file-port)))))))))))
(define (assemble-path path) (define (assemble-path current-directory path)
(log (syslog-level debug) "assembling path ~S" (log (syslog-level debug) "assembling path ~S"
path) path)
(let* ((interim-path (let* ((interim-path
(if (not (file-name-rooted? path)) (if (not (file-name-rooted? path))
(string-append (file-name-as-directory (string-append (file-name-as-directory current-directory)
(session-current-directory))
path) path)
path)) path))
(complete-path (if (file-name-rooted? interim-path) (complete-path (if (file-name-rooted? interim-path)
@ -907,13 +916,10 @@
(cond (cond
((null? components) ((null? components)
(path-list->file-name (reverse reverse-result))) (path-list->file-name (reverse reverse-result)))
((null? (cdr components)) ((string=? ".." (car components))
(if (string=? ".." (car components)) (if (null? reverse-result)
#f #f
(path-list->file-name (loop (cdr components) (cdr reverse-result))))
(reverse (cons (car components) reverse-result)))))
((string=? ".." (cadr components))
(loop (cddr components) reverse-result))
(else (else
(loop (cdr components) (cons (car components) reverse-result)))))) (loop (cdr components) (cons (car components) reverse-result))))))
@ -966,7 +972,7 @@
; Version ; Version
(define *ftpd-version* "$Revision: 1.20 $") (define *ftpd-version* "$Revision: 1.21 $")
(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*)))