diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm index 4f55961..df16a27 100644 --- a/scheme/ftpd/ftpd.scm +++ b/scheme/ftpd/ftpd.scm @@ -2,7 +2,7 @@ ;;; This file is part of the Scheme Untergrund Networking package. -;;; Copyright (c) 1998-2002 by Mike Sperber +;;; Copyright (c) 1998-2003 by Mike Sperber ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. @@ -34,9 +34,10 @@ (define (make-default-ftpd-options) (really-make-ftpd-options 21 "~ftp" - (string-append "Scheme Untergrund ftp server (version " - sunet-version-identifier - ") ready.") + (list + (string-append "Scheme Untergrund ftp server (version " + sunet-version-identifier + ") ready.")) #f #f)) @@ -86,7 +87,7 @@ root-directory current-directory to-be-renamed - reverse-replies + replies reply-code type data-socket @@ -110,8 +111,8 @@ set-session-current-directory!) (to-be-renamed session-to-be-renamed set-session-to-be-renamed!) - (reverse-replies session-reverse-replies - set-session-reverse-replies!) + (replies session-replies + set-session-replies!) (reply-code session-reply-code set-session-reply-code!) (type session-type @@ -132,7 +133,7 @@ #f ; root-directory "" ; current-directory #f ; to-be-renamed - '() ; reverse-replies + '() ; replies #f ; reply-code 'ascii ; type #f ; data-socket @@ -164,7 +165,7 @@ (define the-session-root-directory (make-session-selector session-root-directory)) (define the-session-current-directory (make-session-selector session-current-directory)) (define the-session-to-be-renamed (make-session-selector session-to-be-renamed)) -(define the-session-reverse-replies (make-session-selector session-reverse-replies)) +(define the-session-replies (make-session-selector session-replies)) (define the-session-reply-code (make-session-selector session-reply-code)) (define the-session-type (make-session-selector session-type)) (define the-session-data-socket (make-session-selector session-data-socket)) @@ -187,8 +188,8 @@ (make-session-modifier set-session-current-directory!)) (define set-the-session-to-be-renamed! (make-session-modifier set-session-to-be-renamed!)) -(define set-the-session-reverse-replies! - (make-session-modifier set-session-reverse-replies!)) +(define set-the-session-replies! + (make-session-modifier set-session-replies!)) (define set-the-session-reply-code! (make-session-modifier set-session-reply-code!)) (define set-the-session-type! @@ -330,7 +331,6 @@ ;;; ftpd ------------------------------------------------------- (define (ftpd ftpd-options) - (display ">>>ftpd ") (write (list (ftpd-options-port ftpd-options))) (newline) (with-syslog-destination "ftpd" #f @@ -456,8 +456,7 @@ (define (display-banner) (log (syslog-level debug) "displaying banner (220)") - (register-reply! 220 - (the-ftpd-options-banner))) + (apply register-reply! 220 (the-ftpd-options-banner))) (define-condition-type 'ftpd-quit '()) (define ftpd-quit? (condition-predicate 'ftpd-quit)) @@ -519,42 +518,37 @@ (handle-command command arg))))))) (define (handle-command command arg) -; (log (syslog-level debug) -; "handling command ~S with argument ~S" -; command arg) - (call-with-current-continuation - (lambda (escape) - (with-handler - (lambda (condition more) - (cond - ((error? condition) - (let ((reason (condition-stuff condition))) - (log (syslog-level notice) - "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)" - condition reason) - (register-reply! 451 - (format #f "Internal error: ~S" reason)) - (escape '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 occured (maybe reason: ~S)-- escaping" (condition-stuff condition)) - (escape 'fick-dich-ins-knie)) - (else - (more)))) +;; (log (syslog-level debug) +;; "handling command ~S with argument ~S" +;; command arg) + (with-fatal-error-handler* + (lambda (condition more) + (cond + ((error? condition) + (let ((reason (condition-stuff condition))) + (log (syslog-level notice) + "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)" + condition reason) + (replace-reply! 451 + (format #f "Internal error: ~S" reason)))) + ((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 occured (maybe reason: ~S)-- escaping" (condition-stuff condition))) + (else + (more)))) + (lambda () + (with-errno-handler* + (lambda (errno packet) + (let ((unix-error (car packet))) + (log (syslog-level notice) + "unix error occured: ~S -- replying (451) and escaping" + unix-error) + (replace-reply! 451 + (format #f "Unix error: ~A." unix-error)))) (lambda () - (with-errno-handler* - (lambda (errno packet) - (let ((unix-error (car packet))) - (log (syslog-level notice) - "unix error occured: ~S -- replying (451) and escaping" - unix-error) - (register-reply! 451 - (format #f "Unix error: ~A." unix-error)) - (escape 'fick-dich-ins-knie))) - (lambda () - (dispatch-command command arg)))))))) + (dispatch-command command arg)))))) (define (dispatch-command command arg) ; (log (syslog-level debug) @@ -1286,39 +1280,39 @@ ; Reply handling -; Replies must be synchronous with requests and actions. Therefore, -; they are queued on generation via REGISTER-REPLY!. The messages are -; printed via WRITE-REPLIES. For the nature of the replies, see RFC -; 959. - +; For the nature of the replies, see RFC 959. (define (write-replies) - (if (not (null? (the-session-reverse-replies))) - (let loop ((messages (reverse (the-session-reverse-replies)))) - (if (null? (cdr messages)) - (write-final-reply (car messages)) - (begin - (write-nonfinal-reply (car messages)) - (loop (cdr messages)))))) - (set-the-session-reverse-replies! '())) - -(define (write-final-reply line) - (format (the-session-control-output-port) "~D ~A" (the-session-reply-code) line) - (log (syslog-level debug) "Reply: ~D ~A~%" (the-session-reply-code) line) - (write-crlf (the-session-control-output-port)) - (force-output (the-session-control-output-port))) - -(define (write-nonfinal-reply line) - (format (the-session-control-output-port) "~D-~A" (the-session-reply-code) line) - (log (syslog-level debug) "Reply: ~D-~A~%" (the-session-reply-code) line) - (write-crlf (the-session-control-output-port))) + (let ((replies (the-session-replies))) + (cond + ((null? replies) + (error "no reply registered")) + (else + (let loop ((replies replies)) + (if (not (null? replies)) + (let ((reply-text + (format #f + (if (pair? (cdr replies)) + "~D-~A" + "~D ~A") + (the-session-reply-code) + (car replies)))) + (display reply-text (the-session-control-output-port)) + (write-crlf (the-session-control-output-port)) + (log (syslog-level debug) "Reply: ~A" reply-text) + (loop (cdr replies)))))))) + (set-the-session-reply-code! #f)) (define (signal-error! code message) - (register-reply! code message) + (replace-reply! code message) (signal 'ftpd-error)) -(define (register-reply! code message) - (set-the-session-reverse-replies! - (cons message (the-session-reverse-replies))) +(define (register-reply! code . messages) + (if (the-session-reply-code) + (apply error "tried to register more than one reply" code messages) + (apply replace-reply! code messages))) + +(define (replace-reply! code . messages) + (set-the-session-replies! messages) (set-the-session-reply-code! code))