From a90dfae4961609081ca076a62370a294492e2e56 Mon Sep 17 00:00:00 2001 From: interp Date: Fri, 13 Jul 2001 17:21:39 +0000 Subject: [PATCH] * 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 : ---------------------------------------------------------------------- --- ftpd.scm | 448 ++++++++++++++++++++++++++++++++++---------------- modules.scm | 2 +- stringhax.scm | 26 +-- uri.scm | 5 +- 4 files changed, 328 insertions(+), 153 deletions(-) diff --git a/ftpd.scm b/ftpd.scm index 7e1f0c6..36bc059 100644 --- a/ftpd.scm +++ b/ftpd.scm @@ -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*))) diff --git a/modules.scm b/modules.scm index 112ca1b..e259abf 100644 --- a/modules.scm +++ b/modules.scm @@ -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 diff --git a/stringhax.scm b/stringhax.scm index d4de51f..8f53724 100644 --- a/stringhax.scm +++ b/stringhax.scm @@ -74,16 +74,18 @@ (lambda (s) (char-set-index s non-whitespace)))) ; Why is this so complicated? -; 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))) +; I hope it isn't anymore *g* Andreas +(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 + diff --git a/uri.scm b/uri.scm index 4aa7a17..eddf5f1 100644 --- a/uri.scm +++ b/uri.scm @@ -271,8 +271,8 @@ ;;; URL try to find out if it is a relative path (i.e. it does not ;;; start with a "/"). -(define (simplify-uri-path p) - (if (null? p) #f ; P must be non-null +(define (simplify-uri-path p) + (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)))))))) + \ No newline at end of file