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

* let ftpd generate more useful output on error conditions 

* include format-net package in ftpd package
This commit is contained in:
interp 2001-11-13 13:50:24 +00:00
parent 70306ad10e
commit a76848a6c6
3 changed files with 34 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
format-net.scm
View File

@ -9,16 +9,16 @@
(define (format-internet-host-address address . maybe-separator)
(define (extract shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))
(let-optionals maybe-separator ((separator "."))
(string-append
(extract 24) separator (extract 16) separator
(extract 8) separator (extract 0))))
(let ((extract (lambda (shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))))
(let-optionals maybe-separator ((separator "."))
(string-append
(extract 24) separator (extract 16) separator
(extract 8) separator (extract 0)))))
;; does pretty-print of ports
;; Example:
;; (format-port #x0aff)

61
ftpd.scm
View File

@ -228,8 +228,9 @@
(with-handler
(lambda (condition more)
(log (syslog-level debug)
"hit error condition ~A -- exiting"
(condition-type condition))
"hit error condition ~A (maybe reason (maybe Netscape?): ~S) -- exiting"
(condition-type condition)
(condition-stuff condition))
(display condition (current-error-port))
(escape 'fick-dich-ins-knie))
(lambda ()
@ -317,18 +318,18 @@
(lambda (condition more)
(cond
((error? condition)
(log (syslog-level notice)
"internal error occured: ~S -- replying and escaping (451)"
condition)
(register-reply! 451
(format #f "Internal error: ~S"
(condition-stuff condition)))
(escape 'fick-dich-ins-knie))
(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 -- escaping")
"ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition))
(escape 'fick-dich-ins-knie))
(else
(more))))
@ -781,24 +782,6 @@
(lambda (host-address control-port)
host-address)))
(define (format-internet-host-address address . maybe-separator)
(define (extract shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))
(let ((separator (optional maybe-separator ".")))
(string-append
(extract 24) separator (extract 16) separator
(extract 8) separator (extract 0))))
(define (format-port port)
(string-append
(number->string (bitwise-and (arithmetic-shift port -8) 255))
","
(number->string (bitwise-and port 255))))
(define (handle-nlst arg)
(log-command (syslog-level info) "NLST" arg)
(handle-listing arg '()))
@ -887,11 +870,12 @@
path))))
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
(lambda (condition more)
(log (syslog-level info) "failed to open ~S for reading (550)" full-path)
(log (syslog-level debug) "reporting about ~S" path)
(signal-error! 550
(format #f "Can't open \"~A\" for reading."
path)))
(let ((reason (condition-stuff condition)))
(log (syslog-level info) "failed to open ~S for reading (maybe reason: ~S) (550)" full-path reason)
(log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
(signal-error! 550
(format #f "Can't open \"~A\" for reading."
path))))
(lambda ()
(let ((info (file-info full-path)))
(if (not (eq? 'regular (file-info:type info)))
@ -931,11 +915,10 @@
path))))
(with-fatal-error-handler*
(lambda (condition more)
(log (syslog-level info) "can't open ~S for writing (550)" full-path)
(log (syslog-level debug) "replying error for file ~S" path)
(signal-error! 550
(format #f "Can't open \"~A\" for writing."
path)))
(let ((reason (condition-stuff condition)))
(log (syslog-level info) "can't open ~S for writing (maybe reason: ~S) (550)" full-path reason)
(log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
(signal-error! 550 (format #f "Can't open \"~A\" for writing." path))))
(lambda ()
(call-with-output-file full-path
(lambda (file-port)
@ -1144,7 +1127,7 @@
; Version
(define *ftpd-version* "$Revision: 1.25 $")
(define *ftpd-version* "$Revision: 1.26 $")
(define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*)))

4
modules.scm
View File

@ -479,7 +479,6 @@
scsh)
(files ls))
(define-interface ftpd-interface
(export ftpd
ftpd-inetd))
@ -495,7 +494,8 @@
string-lib
big-util
defrec-package
crlf-io strings ls)
crlf-io strings ls
format-net) ; pretty print of internet-addresses
(access big-scheme)
(files ftpd))