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