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