* 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
parent
f4db620dd9
commit
a90dfae496
448
ftpd.scm
448
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*)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
5
uri.scm
5
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))))))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue