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

- removed some leftover debugging output 

- simplified exception handling (and probably fixed some bugs)
- banners are now lists of lines
- rewrote bogus reply output code
This commit is contained in:
sperber 2003-01-23 09:38:20 +00:00
parent 08bf247510
commit b239184a38
1 changed files with 71 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
scheme/ftpd/ftpd.scm
View File

@ -2,7 +2,7 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998-2002 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; Copyright (c) 1998-2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; 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))