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

+ Moved WITH-DATA-CONNECTION closer to call to LS to avoid stray connections in case of an error 

+ Call surrounding exception handler in WITH-DATA-CONNECTION

+ Add arguments to two calls of escape proecures
This commit is contained in:
mainzelm 2003-07-28 07:50:16 +00:00
parent d7fb759988
commit 0656c89fca
1 changed files with 44 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
scheme/ftpd/ftpd.scm
View File

@ -533,13 +533,13 @@
condition reason) condition reason)
(replace-reply! 451 (replace-reply! 451
(format #f "Internal error: ~S" reason)) (format #f "Internal error: ~S" reason))
(exit))) (exit 'fick-dich-ins-knie)))
((ftpd-error? condition) ((ftpd-error? condition)
;; debug level because nearly every unsuccessful command ends ;; debug level because nearly every unsuccessful command ends
;; here (no args, can't change dir, etc.) ;; here (no args, can't change dir, etc.)
(log (syslog-level debug) (log (syslog-level debug)
"ftpd error occurred (maybe reason: ~S)-- escaping" (condition-stuff condition)) "ftpd error occurred (maybe reason: ~S)-- escaping" (condition-stuff condition))
(exit)) (exit 'fick-dich-ins-knie))
(else (else
(more)))) (more))))
(lambda () (lambda ()
@ -972,39 +972,36 @@
(define (handle-listing arg preset-flags) (define (handle-listing arg preset-flags)
(ensure-authenticated-login) (ensure-authenticated-login)
(with-data-connection (let ((args (split-arguments arg)))
(lambda () (call-with-values
(let ((args (split-arguments arg))) (lambda ()
(call-with-values (partition
(lambda () (lambda (arg)
(partition (and (not (string=? "" arg))
(lambda (arg) (char=? #\- (string-ref arg 0))))
(and (not (string=? "" arg)) args))
(char=? #\- (string-ref arg 0)))) (lambda (flag-args rest-args)
args))
(lambda (flag-args rest-args)
(if (and (not (null? rest-args)) (if (and (not (null? rest-args))
(not (null? (cdr rest-args)))) (not (null? (cdr rest-args))))
(begin (begin
(log (syslog-level info) "got more than one path argument - rejection (501)") (log (syslog-level info) "got more than one path argument - rejection (501)")
(signal-error! 501 "More than one path argument."))) (signal-error! 501 "More than one path argument.")))
(let ((path (if (null? rest-args) (let ((path (if (null? rest-args)
"" ""
(car rest-args))) (car rest-args)))
(flags (arguments->ls-flags flag-args))) (flags (arguments->ls-flags flag-args)))
(if (not flags) (if (not flags)
(begin (begin
(log (syslog-level info) "got invalid flags (501)") (log (syslog-level info) "got invalid flags (501)")
(signal-error! 501 "Invalid flag(s)."))) (signal-error! 501 "Invalid flag(s).")))
(let ((all-flags (append preset-flags flags))) (let ((all-flags (append preset-flags flags)))
(log (syslog-level debug) (log (syslog-level debug)
"sending file-listing for path ~S with flags ~A" "sending file-listing for path ~S with flags ~A"
path all-flags) path all-flags)
(generate-listing path all-flags)))))))
(generate-listing path all-flags)))))))))
; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or ; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
; ENSURE-DATA-CONNECTION. ; ENSURE-DATA-CONNECTION.
@ -1027,17 +1024,19 @@
(with-cwd* (with-cwd*
(file-name-directory full-path) (file-name-directory full-path)
(lambda () (lambda ()
(let ((nondir (file-name-nondirectory full-path))) (with-data-connection
(let-fluid (lambda ()
ls-crlf? #t (let ((nondir (file-name-nondirectory full-path)))
(lambda () (let-fluid
(ls flags ls-crlf? #t
(list (lambda ()
;; work around OLIN BUG (ls flags
(if (string=? nondir "") (list
"." ;; work around OLIN BUG
nondir)) (if (string=? nondir "")
(socket:outport (the-session-data-socket)))))))))))) "."
nondir))
(socket:outport (the-session-data-socket))))))))))))))
(define (handle-abor foo) (define (handle-abor foo)
(log-command (syslog-level info) "ABOR") (log-command (syslog-level info) "ABOR")
@ -1215,7 +1214,8 @@
(ensure-data-connection) (ensure-data-connection)
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (condition more) (lambda (condition more)
(maybe-close-data-connection)) (maybe-close-data-connection)
(more))
(lambda () (lambda ()
(thunk) (thunk)
(maybe-close-data-connection) (maybe-close-data-connection)