* finished adding syslogs to ftpd

* trim-spaces doesn't throw exception on emtpy strings any more
* spawn-thunk in FTPD moved to new procedure
* always catching SOCKET->STRING errors
* log-calls don't produce extra calculations anymore
* consequently logging reply codes
: ----------------------------------------------------------------------
This commit is contained in:
interp 2001-07-13 17:21:39 +00:00
parent f4db620dd9
commit a90dfae496
4 changed files with 328 additions and 153 deletions

448
ftpd.scm
View File

@ -11,6 +11,17 @@
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
; following things should be improved:
;
; - GET-command: ftpd reports "Can't open FILENAME for reading" if
; file actually doesn't exist. This is confusing. Reporting
; "FILENAME does not exist" is much better.
; - logging:
; * improve syslog-levels (too much debug-messages?)
; * improve perfomance (values are often calculated twice: first
; time for logging, second time for reporting
; BRNR: STOPPED at 836
(define-record session
control-input-port
control-output-port
@ -76,6 +87,16 @@
(apply format #f (string-append "(thread ~D) " format-message)
(thread-uid (current-thread)) args)))
(define (log-command command-name . argument)
(if (null? argument)
(log (syslog-level debug) "handling ~A-command" command-name)
(if (not (null? (cdr argument)))
(log (syslog-level debug) "handling ~A-command with arguments ~S"
command-name argument)
(log (syslog-level debug) "handling ~A-command with argument ~S"
command-name (car argument)))))
;;; CONVERTERS ------------------------------------------------
(define (protocol-family->string protocol-family)
(cond ((= protocol-family protocol-family/unspecified)
@ -113,54 +134,67 @@
#f
#f
(lambda ()
(log (syslog-level notice)
"starting on port ~D with ~S as anonymous home"
port (expand-file-name anonymous-home (cwd)))
(bind-listen-accept-loop
protocol-family/internet
(lambda (socket address)
(log (syslog-level info)
"new connection with ~S"
(socket-address->string address))
(log (syslog-level debug)
"got connection with socket ~S and address ~S"
(socket->string socket)
(socket-address->string address))
(set-ftp-socket-options! socket)
(spawn
(lambda ()
(handle-connection (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home))
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((or (= errno errno/notconn)
;; this one can come out of SOCKET->STRING
(= errno errno/inval))
(log (syslog-level warning)
"socket not connected any more - exiting thread")
(exit 'fick-dich-ins-knie))))
(lambda ()
(log (syslog-level debug)
"shutting down socket ~S"
(socket->string socket))
(shutdown-socket socket shutdown/sends+receives)))))
(log (syslog-level info)
"closing socket")
(close-socket socket))
(socket-address->string address))) ; use remote address as thread-name
(let ((remote-address (socket-address->string address)))
(set-ftp-socket-options! socket)
(spawn
(spawn-to-handle-connection socket
address
anonymous-home
port
remote-address)
remote-address))) ; use remote address as thread-name
port)))))
(define (spawn-to-handle-connection socket address anonymous-home port remote-address)
(lambda ()
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((or (= errno errno/notconn)
;; this one can come out of SOCKET->STRING
(= errno errno/inval))
(log (syslog-level info)
"socket to ~A not connected any more - exiting"
remote-address)
(exit 'fick-dich-ins-knie))))
(lambda ()
(let ((socket-string (socket->string socket)))
(log (syslog-level info)
"new connection to ~S"
remote-address)
(log (syslog-level debug)
"got connection with socket ~S and address ~S"
socket-string
remote-address)
(handle-connection (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home))
(log (syslog-level debug)
"shutting down socket ~S"
socket-string)
(shutdown-socket socket shutdown/sends+receives)
(log (syslog-level info)
"closing socket to ~A and finishing thread" remote-address)
(log (syslog-level debug)
"closing socket (~A) and finishing thread" socket-string)
(close-socket socket))))))))
(define (ftpd-inetd anonymous-home)
(with-syslog-destination
"ftpd"
@ -214,7 +248,7 @@
(define (display-banner)
(log (syslog-level debug)
"displaying banner")
"displaying banner (220)")
(register-reply! 220
(string-append
"Scheme Untergrund ftp server ("
@ -239,7 +273,7 @@
(lambda (condition more)
(if (ftpd-quit? condition)
(begin
(log (syslog-level debug) "quitting")
(log (syslog-level debug) "quitting (write-accept-loop)")
(with-handler
(lambda (condition ignore)
(more))
@ -266,7 +300,7 @@
command-line)
(cond ((eq? command-line 'timeout)
(log (syslog-level debug)
"hit timelimit (~D seconds) -- closing control connection."
"hit timelimit (~D seconds) -- closing control connection and quitting (421)"
timeout-seconds)
(register-reply!
421
@ -280,9 +314,9 @@
(handle-command command arg)))))))
(define (handle-command command arg)
(log (syslog-level debug)
"handling command ~S with argument ~S"
command arg)
; (log (syslog-level debug)
; "handling command ~S with argument ~S"
; command arg)
(call-with-current-continuation
(lambda (escape)
(with-handler
@ -290,36 +324,36 @@
(cond
((error? condition)
(log (syslog-level notice)
"internal error occured: ~S -- replying (451) and escaping"
"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))
((ftpd-error? condition)
(log (syslog-level notice)
(log (syslog-level debug)
"ftpd error occured: ~S -- escaping"
; must this occur everytime CDUP is called in ftp-root-path?
(condition-stuff condition))
condition)
(escape 'fick-dich-ins-knie))
(else
(more))))
(lambda ()
(with-errno-handler*
(lambda (errno packet)
(log (syslog-level notice)
"unix error occured: ~S -- replying (451) and escaping"
(car packet))
(register-reply! 451
(format #f "Unix error: ~A." (car packet)))
(escape 'fick-dich-ins-knie))
(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))))))))
(define (dispatch-command command arg)
(log (syslog-level debug)
"dispatching command ~S with argument ~S"
command arg)
; (log (syslog-level debug)
; "dispatching command ~S with argument ~S"
; command arg)
(cond
((assoc command *command-alist*)
=> (lambda (pair)
@ -339,8 +373,7 @@
(define (handle-user name)
(log (syslog-level debug) "handling USER-command with name ~S"
name)
(log-command "USER" name)
(cond
((session-logged-in?)
(log (syslog-level debug) "user ~S is already logged in (230)"
@ -366,8 +399,7 @@
(register-reply! 230 "Anonymous user logged in."))
(define (handle-pass password)
(log (syslog-level debug) "handling PASS-command with password ~S"
password)
(log-command "PASS" password)
(cond
((not (session-logged-in?))
(log (syslog-level debug) "Rejecting password as user is not logged in yet. (530)")
@ -380,29 +412,31 @@
(register-reply! 502 "This can't happen."))))
(define (handle-quit foo)
(log (syslog-level debug) "handling QUIT-command (221)")
(log-command "QUIT")
(log (syslog-level debug) "quitting (221)")
(register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!")
(signal 'ftpd-quit))
(define (handle-syst foo)
(log-command "SYST")
(log (syslog-level debug) "telling system type (215)")
(register-reply! 215 "UNIX Type: L8"))
(define (handle-cwd path)
(log (syslog-level debug) "handling CWD-command with ~S as path-argument"
path)
(log-command "CWD" path)
(ensure-authenticated-login)
(let ((current-directory (assemble-path (session-current-directory)
path)))
(with-errno-handler*
(lambda (errno packet)
(log (syslog-level debug)
"can't change to directory \"~A\": ~A (550)"
path (car packet))
(signal-error! 550
(let ((error-reason (car packet)))
(log (syslog-level debug)
"can't change to directory \"~A\": ~A (550)"
path error-reason)
(signal-error! 550
(format #f "Can't change directory to \"~A\": ~A."
path
(car packet))))
error-reason))))
(lambda ()
(with-cwd*
(file-name-as-directory
@ -417,32 +451,39 @@
current-directory))))))))
(define (handle-cdup foo)
(log (syslog-level debug) "handling CDUP-command as \"CWD ..\"")
(log-command "CDUP")
(handle-cwd ".."))
(define (handle-pwd foo)
(log (syslog-level debug) "handling PWD-command")
(log-command "PWD")
(ensure-authenticated-login)
(log (syslog-level debug) "replying \"/~A\" as current directory (257)"
(session-current-directory))
(register-reply! 257
(format #f "Current directory is \"/~A\"."
(session-current-directory))))
(let ((current-directory (session-current-directory)))
(log (syslog-level debug) "replying \"/~A\" as current directory (257)"
current-directory)
(register-reply! 257
(format #f "Current directory is \"/~A\"."
current-directory))))
(define (make-file-action-handler error-format-string action)
(lambda (path)
(ensure-authenticated-login)
(if (string=? "" path)
(signal-error! 500 "No argument."))
(begin
(log (syslog-level debug)
"finishing processing command because of missing arguments (500)")
(signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory)
path))))
(with-errno-handler*
(lambda (errno packet)
(signal-error! 550
(format #f error-format-string
path (car packet))))
(let ((error-reason (car packet)))
(log (syslog-level debug)
(string-append error-format-string " (550)") path error-reason)
(signal-error! 550
(format #f error-format-string
path error-reason))))
(lambda ()
(action path full-path))))))
@ -450,23 +491,35 @@
(make-file-action-handler
"Could not delete \"~A\": ~A."
(lambda (path full-path)
(log-command "DELE" path)
(delete-file full-path)
(log (syslog-level debug) "deleted ~S, reporting deletion of ~S (250)"
full-path path)
(register-reply! 250 (format #f "Deleted \"~A\"." path)))))
(define handle-mdtm
(make-file-action-handler
"Could not get info on \"~A\": ~A."
(lambda (path full-path)
(log-command "MDTM" path)
(let* ((info (file-info full-path))
(the-date (date (file-info:mtime info) 0)))
(the-date (date (file-info:mtime info) 0))
(formatted-date (format-date "~Y~m~d~H~M~S" the-date)))
(log (syslog-level debug) "reporting modification time of ~S: ~A (213)"
full-path
formatted-date)
(register-reply! 213
(format-date "~Y~m~d~H~M~S" the-date))))))
formatted-date)))))
(define handle-mkd
(make-file-action-handler
"Could not make directory \"~A\": ~A."
(lambda (path full-path)
(log-command "MKD" path)
(create-directory full-path #o755)
(log (syslog-level debug)
"created directory ~S, reporting creation of directory ~S (257)"
full-path path)
(register-reply! 257
(format #f "Created directory \"~A\"." path)))))
@ -474,7 +527,11 @@
(make-file-action-handler
"Could not remove directory \"~A\": ~A."
(lambda (path full-path)
(log-command "RMD" path)
(delete-directory full-path)
(log (syslog-level debug)
"deleted directory ~S, reporting deletion of directory ~S (250)"
full-path path)
(register-reply! 250
(format #f "Deleted directory \"~A\"." path)))))
@ -483,59 +540,95 @@
(make-file-action-handler
"Could not get info on file \"~A\": ~A."
(lambda (path full-path)
(log-command "RNFR" path)
(file-info full-path)
(log (syslog-level debug)
"RNFR-command accepted, waiting for RNTO-command (350)")
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
(set-session-to-be-renamed full-path))))
(define (handle-rnto path)
(log-command "RNTO" path)
(ensure-authenticated-login)
(if (not (session-to-be-renamed))
(signal-error! 503 "Need RNFR before RNTO."))
(begin
(log (syslog-level debug)
"RNTO-command rejected: need RNFR-command before (503)")
(signal-error! 503 "Need RNFR before RNTO.")))
(if (string=? "" path)
(signal-error! 500 "No argument."))
(begin
(log (syslog-level debug)
"No argument -- still waiting for (correct) RNTO-command (500)")
(signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory)
path))))
(if (file-exists? full-path)
(signal-error!
550
(format #f "Rename failed---\"~A\" already exists or is protected."
path)))
(begin
(log (syslog-level debug)
"rename of ~S failed (already exists), reporting failure of renaming ~S (550)"
full-path path)
(signal-error!
550
(format #f "Rename failed---\"~A\" already exists or is protected."
path))))
(with-errno-handler*
(lambda (errno packet)
(log (syslog-level debug)
"failed to rename ~A (550)" path)
(signal-error! 550
(format #f "Could not rename: ~A." path)))
(lambda ()
(rename-file (session-to-be-renamed) full-path)
(register-reply! 250 "File renamed.")
(set-session-to-be-renamed #f)))))
(let ((old-name (session-to-be-renamed)))
(rename-file old-name full-path)
(log (syslog-level debug)
"~S renamed to ~S - no more waiting for RNTO-command (250)"
old-name full-path)
(register-reply! 250 "File renamed.")
(set-session-to-be-renamed #f))))))
(define handle-size
(make-file-action-handler
"Could not get info on file \"~A\": ~A."
(lambda (path full-path)
(log-command "SIZE" path)
(let ((info (file-info full-path)))
(if (not (eq? 'regular (file-info:type info)))
(signal-error! 550
(format #f "\"~A\" is not a regular file."
path)))
(register-reply! 213 (number->string (file-info:size info)))))))
(begin
(log (syslog-level debug)
"rejecting SIZE-command as ~S is not a regular file, reporting on ~S (550)"
full-path path)
(signal-error! 550
(format #f "\"~A\" is not a regular file."
path))))
(let ((file-size (file-info:size info)))
(log (syslog-level debug)
"reporting ~D as size of ~S (213)"
file-size full-path)
(register-reply! 213 (number->string file-size)))))))
(define (handle-type arg)
(log-command "TYPE" arg)
(cond
((string-ci=? "A" arg)
(log (syslog-level debug) "changed type to ascii")
(set-session-type 'ascii))
((string-ci=? "I" arg)
(log (syslog-level debug) "changed type to image")
(set-session-type 'image))
((string-ci=? "L8" arg)
(log (syslog-level debug) "changed type to image")
(set-session-type 'image))
(else
(log (syslog-level debug)
"rejecting TYPE-command: unknown type (504)")
(signal-error! 504
(format #f "Unknown TYPE: ~A." arg))))
(format #f "Unknown TYPE: ~S." arg))))
(log (syslog-level debug) "reporting new type (see previous log) (200)")
(register-reply! 200
(format #f "TYPE is now ~A."
(case (session-type)
@ -544,35 +637,47 @@
(else "somethin' weird, man")))))
(define (handle-mode arg)
(log-command "MODE" arg)
(cond
((string=? "" arg)
(log (syslog-level debug) "rejecting MODE-command: no arguments (500)")
(register-reply! 500
"No arguments. Not to worry---I'd ignore them anyway."))
((string-ci=? "S" arg)
(log (syslog-level debug)
"stream mode is (still) used for file-transfer (200)")
(register-reply! 200 "Using stream mode to transfer files."))
(else
(log (syslog-level debug) "mode ~S is not supported (504)" arg)
(register-reply! 504 (format #f "Mode \"~A\" is not supported."
arg)))))
(define (handle-stru arg)
(log-command "STRU" arg)
(cond
((string=? "" arg)
(log (syslog-level debug) "rejecting STRU-command: no arguments (500)")
(register-reply! 500
"No arguments. Not to worry---I'd ignore them anyway."))
((string-ci=? "F" arg)
(log (syslog-level debug) "(still) using file structure to tranfser files (200)")
(register-reply! 200 "Using file structure to transfer files."))
(else
(log (syslog-level debug) "file structure ~S is not supported (504)" arg)
(register-reply! 504
(format #f "File structure \"~A\" is not supported."
arg)))))
(define (handle-noop arg)
(log-command "NOOP")
(log (syslog-level debug) "successfully done nothing (200)")
(register-reply! 200 "Done nothing, but successfully."))
(define *port-arg-regexp*
(make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
(define (parse-port-arg string)
(log (syslog-level debug) "parsing port-string ~S" string)
(cond
((regexp-exec *port-arg-regexp* string)
=> (lambda (match)
@ -584,23 +689,32 @@
(if (any? (lambda (component)
(> component 255))
components)
(signal-error! 501
"Invalid arguments to PORT."))
(begin
(log (syslog-level debug)
"rejecting PORT-command because of invalid arguments (port-component > 255) (501)")
(signal-error! 501
"Invalid arguments to PORT.")))
(apply
(lambda (a1 a2 a3 a4 p1 p2)
(values (+ (arithmetic-shift a1 24)
(arithmetic-shift a2 16)
(arithmetic-shift a3 8)
a4)
(+ (arithmetic-shift p1 8)
p2)))
(let ((address (+ (arithmetic-shift a1 24)
(arithmetic-shift a2 16)
(arithmetic-shift a3 8)
a4))
(port (+ (arithmetic-shift p1 8) p2)))
(log (syslog-level debug)
"port-parse result: address ~D, port ~D (from compononets: address: ~A, ~A, ~A, ~A, port: ~A, ~A)"
address port
a1 a2 a3 a4 p1 p2)
(values address port)))
components))))
(else
(log (syslog-level debug) "reporting syntax error in argument (500)")
(signal-error! 500
"Syntax error in argument to PORT."))))
(define (handle-port stuff)
(log-command "PORT" stuff)
(ensure-authenticated-login)
(maybe-close-data-connection)
(call-with-values
@ -608,7 +722,8 @@
(lambda (address port)
(let ((socket (create-socket protocol-family/internet
socket-type/stream)))
(log (syslog-level debug)
"created new socket (internet, stream, reusing address)")
(set-socket-option socket level/socket socket/reuse-address #t)
(connect-socket socket
@ -617,13 +732,20 @@
(set-session-data-socket socket)
(register-reply! 200
(format #f "Connected to ~A, port ~A."
(format-internet-host-address address)
port))))))
(let ((formatted-internet-host-address
(format-internet-host-address address)))
(log (syslog-level debug)
"connected to ~A, port ~A (200)"
formatted-internet-host-address port)
(register-reply! 200
(format #f "Connected to ~A, port ~A."
formatted-internet-host-address
port)))))))
(define (handle-pasv stuff)
(log-command "PASV")
(ensure-authenticated-login)
(maybe-close-data-connection)
(let ((socket (create-socket protocol-family/internet
@ -644,12 +766,16 @@
(set-session-passive-socket socket)
(register-reply! 227
(format #f "Passive mode OK (~A,~A)"
(format-internet-host-address
(this-host-address)
",")
(format-port port))))))))
(let ((formatted-this-host-address
(format-internet-host-address (this-host-address) ","))
(formatted-port (format-port port)))
(log (syslog-level debug) "accepting passive mode (on ~A,~A) (227)"
formatted-this-host-address formatted-port)
(register-reply! 227
(format #f "Passive mode OK (~A,~A)"
formatted-this-host-address
formatted-port))))))))
(define (this-host-address)
(call-with-values
@ -679,9 +805,11 @@
(number->string (bitwise-and port 255))))
(define (handle-nlst arg)
(log-command "NLST" arg)
(handle-listing arg '()))
(define (handle-list arg)
(log-command "LIST" arg)
(handle-listing arg '(long)))
(define (handle-listing arg preset-flags)
@ -700,7 +828,9 @@
(if (and (not (null? rest-args))
(not (null? (cdr rest-args))))
(signal-error! 501 "More than one path argument."))
(begin
(log (syslog-level debug) "got more than one path argument (501")
(signal-error! 501 "More than one path argument.")))
(let ((path (if (null? rest-args)
""
@ -708,9 +838,15 @@
(flags (arguments->ls-flags flag-args)))
(if (not flags)
(signal-error! 501 "Invalid flag(s)."))
(begin
(log (syslog-level debug) "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 (append preset-flags flags)))))))))
(generate-listing path all-flags)))))))))
; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
; ENSURE-DATA-CONNECTION.
@ -721,10 +857,14 @@
path))))
(with-errno-handler*
(lambda (errno packet)
(signal-error! 451
(format #f "Can't access directory at ~A: ~A."
path
(car packet))))
(let ((error-reason (car packet)))
(log (syslog-level debug)
"can't access directory at ~A: ~A (451)"
path error-reason)
(signal-error! 451
(format #f "Can't access directory at ~A: ~A."
path
error-reason))))
(lambda ()
(with-cwd*
(file-name-directory full-path)
@ -739,46 +879,66 @@
(socket:outport (session-data-socket))))))))))
(define (handle-abor foo)
(log-command "ABOR")
(maybe-close-data-connection)
(log (syslog-level debug) "closing data connection (226)")
(register-reply! 226 "Closing data connection."))
(define (handle-retr path)
(log-command "RETR")
(ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory)
path))))
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
(lambda (condition more)
(log (syslog-level debug)
"failed to open ~S for reading - replying error for file ~S (550)"
full-path path)
(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)))
(signal-error! 450
(format #f "\"~A\" is not a regular file."
path)))
(begin
(log (syslog-level debug)
"~S is not a regular file - replying error for ~S (450)"
full-path path)
(signal-error! 450
(format #f "\"~A\" is not a regular file."
path))))
(call-with-input-file full-path
(lambda (file-port)
(with-data-connection
(lambda ()
(case (session-type)
((image)
(log (syslog-level debug)
"sending file ~S in binary mode from port ~S"
full-path file-port)
(copy-port->port-binary
file-port
(socket:outport (session-data-socket))))
((ascii)
(log (syslog-level debug)
"sending file ~S in ascii mode from port ~S"
full-path file-port)
(copy-port->port-ascii
file-port
(socket:outport (session-data-socket))))))))))))))
(define (handle-stor path)
(log-command "STOR" path)
(ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory)
path))))
(with-fatal-error-handler*
(lambda (condition more)
(log (syslog-level debug)
"can't open ~S for writing -- replying error for ~S (550)"
full-path path)
(signal-error! 550
(format #f "Can't open \"~A\" for writing."
path)))
@ -787,15 +947,22 @@
(lambda (file-port)
(with-data-connection
(lambda ()
(case (session-type)
((image)
(copy-port->port-binary
(socket:inport (session-data-socket))
file-port))
(let ((inport (socket:inport (session-data-socket))))
(case (session-type)
((image)
(log (syslog-level debug)
"storing data to ~S from socket-inport ~S (binary-mode)"
full-path inport)
(copy-port->port-binary
(socket:inport (session-data-socket))
file-port))
((ascii)
(log (syslog-level debug)
"storing data to ~S from socket-inport ~S (ascii-mode)"
full-path inport)
(copy-ascii-port->port
(socket:inport (session-data-socket))
file-port)))))))))))
file-port))))))))))))
(define (assemble-path current-directory path)
(log (syslog-level debug) "assembling path ~S"
@ -808,7 +975,7 @@
(complete-path (if (file-name-rooted? interim-path)
(file-name-sans-rooted interim-path)
interim-path)))
(log (syslog-level debug) "path ~S assembled to ~S"
(log (syslog-level debug) "name ~S assembled to ~S"
path complete-path)
(cond
((normalize-path complete-path)
@ -822,9 +989,10 @@
(if (or (not (session-logged-in?))
(not (session-authenticated?)))
(begin
(log (syslog-level debug) "login authentication failed - user is not logged in (530)")
(log (syslog-level debug)
"login authentication failed - user is not logged in (530)")
(signal-error! 530 "You're not logged in yet."))
(log (syslog-level debug) "authenticated login ensured.")))
(log (syslog-level debug) "authenticated login ensured")))
(define (with-data-connection thunk)
(dynamic-wind ensure-data-connection
@ -836,7 +1004,9 @@
(define (ensure-data-connection)
(if (and (not (session-data-socket))
(not (session-passive-socket)))
(signal-error! 425 "No data connection."))
(begin
(log (syslog-level debug) "no data connection (425)")
(signal-error! 425 "No data connection.")))
(if (session-passive-socket)
(call-with-values
@ -844,6 +1014,7 @@
(lambda (socket socket-address)
(set-session-data-socket socket))))
(log (syslog-level debug) "opening data connection (150)")
(register-reply! 150 "Opening data connection.")
(write-replies)
@ -861,6 +1032,7 @@
(close-socket (session-data-socket)))
(if (session-passive-socket)
(close-socket (session-passive-socket)))
(log (syslog-level debug) "closing data connection (226)")
(register-reply! 226 "Closing data connection.")
(set-session-data-socket #f)
(set-session-passive-socket #f))
@ -972,7 +1144,7 @@
; Version
(define *ftpd-version* "$Revision: 1.22 $")
(define *ftpd-version* "$Revision: 1.23 $")
(define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*)))

View File

@ -424,7 +424,7 @@
structure-refs
handle-fatal-error
scsh
threads threads-internal
threads threads-internal ; last one to get CURRENT-THREAD
fluids
string-lib
big-util

View File

@ -74,16 +74,18 @@
(lambda (s) (char-set-index s non-whitespace))))
; Why is this so complicated?
; Hope, it isn't anymore *g* Andreas
; I hope it isn't anymore *g* Andreas
(define (trim-spaces string)
(let* ((the-loop
(lambda (start incr)
(let lp ((i start))
(if (char=? #\space (string-ref string i))
(lp (+ i incr))
i))))
(start (the-loop 0 1))
(end (+ 1 (the-loop (- (string-length string) 1) -1))))
(substring string start end)))
(define (trim-spaces string) ; trims spaces from left and right
(if (string=? "" string)
string
(let* ((the-loop
(lambda (start incr) ; start-point and increment (+1 or -1)
(let lp ((i start))
(if (char=? #\space (string-ref string i))
(lp (+ i incr)) ; still spaces, go ahead
i)))) ; first non-space-character
(start (the-loop 0 1)) ; from left
(end (+ 1 (the-loop (- (string-length string) 1) -1)))) ; from right
(substring string start end)))) ; in the middle

View File

@ -272,7 +272,7 @@
;;; start with a "/").
(define (simplify-uri-path p)
(if (null? p) #f ; P must be non-null
(if (null? p) #f ; P must be non-null
(let lp ((path-list (cdr p))
(stack (list (car p))))
(if (null? path-list) ; we're done
@ -290,3 +290,4 @@
(else ; usual segment
(lp (cdr path-list) (cons (car path-list) stack))))))))