853 lines
25 KiB
Scheme
853 lines
25 KiB
Scheme
; RFC 959 ftp daemon
|
|
|
|
; Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
|
; Copyright (c) 1998 Michael Sperber.
|
|
|
|
; It doesn't support the following desirable things:
|
|
;
|
|
; - Login by user; this requires crypt which scsh doesn't have
|
|
; - RESTART support
|
|
; - Banners from files on CWD
|
|
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
|
|
|
|
|
|
(define-record session
|
|
control-input-port
|
|
control-output-port
|
|
(logged-in? #f)
|
|
(authenticated? #f)
|
|
(anonymous? #f)
|
|
(root-directory #f)
|
|
(current-directory "")
|
|
(to-be-renamed #f)
|
|
(reverse-replies '())
|
|
(reply-code #f) ; the last one wins
|
|
(type 'ascii) ; PLEASE set this to bin
|
|
(data-socket #f)
|
|
(passive-socket #f))
|
|
|
|
(define session (make-fluid #f))
|
|
|
|
(define (make-fluid-selector selector)
|
|
(lambda () (selector (fluid session))))
|
|
|
|
(define (make-fluid-setter setter)
|
|
(lambda (value)
|
|
(setter (fluid session) value)))
|
|
|
|
|
|
(define session-control-input-port (make-fluid-selector session:control-input-port))
|
|
(define session-control-output-port (make-fluid-selector session:control-output-port))
|
|
(define session-logged-in? (make-fluid-selector session:logged-in?))
|
|
(define session-authenticated? (make-fluid-selector session:authenticated?))
|
|
(define session-anonymous? (make-fluid-selector session:anonymous?))
|
|
(define session-root-directory (make-fluid-selector session:root-directory))
|
|
(define session-current-directory (make-fluid-selector session:current-directory))
|
|
(define session-to-be-renamed (make-fluid-selector session:to-be-renamed))
|
|
(define session-reverse-replies (make-fluid-selector session:reverse-replies))
|
|
(define session-reply-code (make-fluid-selector session:reply-code))
|
|
(define session-type (make-fluid-selector session:type))
|
|
(define session-data-socket (make-fluid-selector session:data-socket))
|
|
(define session-passive-socket (make-fluid-selector session:passive-socket))
|
|
|
|
(define set-session-control-input-port
|
|
(make-fluid-setter set-session:control-input-port))
|
|
(define set-session-control-output-port
|
|
(make-fluid-setter set-session:control-output-port))
|
|
(define set-session-logged-in? (make-fluid-setter set-session:logged-in?))
|
|
(define set-session-authenticated? (make-fluid-setter set-session:authenticated?))
|
|
(define set-session-anonymous? (make-fluid-setter set-session:anonymous?))
|
|
(define set-session-root-directory (make-fluid-setter set-session:root-directory))
|
|
(define set-session-current-directory (make-fluid-setter set-session:current-directory))
|
|
(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed))
|
|
(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies))
|
|
(define set-session-reply-code (make-fluid-setter set-session:reply-code))
|
|
(define set-session-type (make-fluid-setter set-session:type))
|
|
(define set-session-data-socket (make-fluid-setter set-session:data-socket))
|
|
(define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
|
|
|
|
(define (ftpd . maybe-port)
|
|
(let ((port (optional maybe-port 21)))
|
|
(bind-listen-accept-loop
|
|
protocol-family/internet
|
|
(lambda (socket address)
|
|
|
|
(set-ftp-socket-options! socket)
|
|
|
|
(spawn
|
|
(lambda ()
|
|
(handle-connection (socket:inport socket)
|
|
(socket:outport socket))
|
|
(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
|
|
((= errno errno/notconn)
|
|
(exit 'fick-dich-ins-knie))))
|
|
(lambda ()
|
|
(shutdown-socket socket shutdown/sends+receives)
|
|
(close-socket socket))))))))
|
|
|
|
port)))
|
|
|
|
(define (ftpd-inetd)
|
|
(handle-connection (current-input-port)
|
|
(current-output-port)))
|
|
|
|
(define (set-ftp-socket-options! socket)
|
|
;; If the client closes the connection, we won't lose when we try to
|
|
;; close the socket by trying to flush the output buffer.
|
|
(set-port-buffering (socket:outport socket) bufpol/none)
|
|
|
|
(set-socket-option socket level/socket socket/oob-inline #t))
|
|
|
|
|
|
(define (handle-connection input-port output-port)
|
|
(call-with-current-continuation
|
|
(lambda (escape)
|
|
(with-handler
|
|
(lambda (condition more)
|
|
(display condition (current-error-port))
|
|
(escape 'fick-dich-ins-knie))
|
|
(lambda ()
|
|
(let-fluid session (make-session input-port output-port)
|
|
(lambda ()
|
|
(display-banner)
|
|
(handle-commands))))))))
|
|
|
|
(define (display-banner)
|
|
(register-reply! 220
|
|
(string-append
|
|
"Scheme Untergrund ftp server ("
|
|
*ftpd-version*
|
|
") ready.")))
|
|
|
|
(define-condition-type 'ftpd-quit '())
|
|
(define ftpd-quit? (condition-predicate 'ftpd-quit))
|
|
|
|
(define-condition-type 'ftpd-error '())
|
|
(define ftpd-error? (condition-predicate 'ftpd-error))
|
|
|
|
|
|
(define (handle-commands)
|
|
(with-handler
|
|
(lambda (condition more)
|
|
;; this in really only for ftpd-quit
|
|
(write-replies)
|
|
(more))
|
|
(lambda ()
|
|
(let loop ()
|
|
(write-replies)
|
|
(accept-command)
|
|
(loop)))))
|
|
|
|
(define (accept-command)
|
|
(let ((command-line (read-crlf-line-timeout (session-control-input-port)
|
|
#f
|
|
90000 ; timeout
|
|
500))) ; max interval
|
|
;; (format #t "Command line: ~A~%" command-line)
|
|
(cond ((eq? command-line 'timeout)
|
|
(register-reply!
|
|
421
|
|
"Timeout (900 seconds): closing control connection.")
|
|
(signal 'ftpd-quit))
|
|
(else
|
|
(call-with-values
|
|
(lambda () (parse-command-line command-line))
|
|
(lambda (command arg)
|
|
(handle-command command arg)))))))
|
|
|
|
(define (handle-command command arg)
|
|
(call-with-current-continuation
|
|
(lambda (escape)
|
|
(with-handler
|
|
(lambda (condition more)
|
|
(cond
|
|
((error? condition)
|
|
(register-reply! 451
|
|
(format #f "Internal error: ~S"
|
|
(condition-stuff condition)))
|
|
(escape 'fick-dich-ins-knie))
|
|
((ftpd-error? condition)
|
|
(escape 'fick-dich-ins-knie))
|
|
(else
|
|
(more))))
|
|
(lambda ()
|
|
(with-errno-handler*
|
|
(lambda (errno packet)
|
|
(register-reply! 451
|
|
(format #f "Unix error: ~A." (car packet)))
|
|
(escape 'fick-dich-ins-knie))
|
|
(lambda ()
|
|
(dispatch-command command arg))))))))
|
|
|
|
(define (dispatch-command command arg)
|
|
(cond
|
|
((assoc command *command-alist*)
|
|
=> (lambda (pair)
|
|
((cdr pair) arg)))
|
|
(else
|
|
(register-reply! 500
|
|
(string-append
|
|
(format #f "Unknown command: \"~A\"" command)
|
|
(if (string=? "" arg)
|
|
"."
|
|
(format #f " (argument(s) \"~A\")." arg)))))))
|
|
|
|
|
|
(define (handle-user name)
|
|
(cond
|
|
((session-logged-in?)
|
|
(register-reply! 230
|
|
"You are already logged in."))
|
|
((or (string=? "anonymous" name)
|
|
(string=? "ftp" name))
|
|
(handle-user-anonymous))
|
|
(else
|
|
(register-reply! 530
|
|
"Only anonymous logins allowed."))))
|
|
|
|
(define (handle-user-anonymous)
|
|
(let ((ftp-info '(user-info "gasbichl")))
|
|
|
|
'(set-gid (user-info:gid ftp-info))
|
|
'(set-uid (user-info:uid ftp-info))
|
|
|
|
(set-session-logged-in? #t)
|
|
(set-session-authenticated? #t)
|
|
(set-session-anonymous? #t)
|
|
(set-session-root-directory "/afs/informatik.uni-tuebingen.de/data/ftp/")
|
|
(set-session-current-directory "")
|
|
|
|
(register-reply! 230 "Anonymous user logged in.")))
|
|
|
|
(define (handle-pass password)
|
|
(cond
|
|
((not (session-logged-in?))
|
|
(register-reply! 530 "You have not logged in yet."))
|
|
((session-anonymous?)
|
|
(register-reply! 200 "Thank you."))
|
|
(else
|
|
(register-reply! 502 "This can't happen."))))
|
|
|
|
(define (handle-quit foo)
|
|
(register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!")
|
|
(signal 'ftpd-quit))
|
|
|
|
(define (handle-syst foo)
|
|
(register-reply! 215 "UNIX Type: L8"))
|
|
|
|
(define (handle-cwd path)
|
|
(ensure-authenticated-login)
|
|
(let ((current-directory (assemble-path path)))
|
|
(with-errno-handler*
|
|
(lambda (errno packet)
|
|
(signal-error! 550
|
|
(format #f "Can't change directory to \"~A\": ~A."
|
|
path
|
|
(car packet))))
|
|
(lambda ()
|
|
(with-cwd*
|
|
(file-name-as-directory
|
|
(string-append (session-root-directory) current-directory))
|
|
(lambda () ; I hate gratuitous syntax
|
|
(set-session-current-directory current-directory)
|
|
(register-reply! 250
|
|
(format #f "Current directory changed to \"/~A\"."
|
|
current-directory))))))))
|
|
|
|
(define (handle-cdup foo)
|
|
(handle-cwd ".."))
|
|
|
|
(define (handle-pwd foo)
|
|
(ensure-authenticated-login)
|
|
(register-reply! 257
|
|
(format #f "Current directory is \"/~A\"."
|
|
(session-current-directory))))
|
|
|
|
|
|
(define (make-file-action-handler error-format-string action)
|
|
(lambda (path)
|
|
(ensure-authenticated-login)
|
|
(if (string=? "" path)
|
|
(signal-error! 500 "No argument."))
|
|
(let ((full-path (string-append (session-root-directory)
|
|
(assemble-path path))))
|
|
(with-errno-handler*
|
|
(lambda (errno packet)
|
|
(signal-error! 550
|
|
(format #f error-format-string
|
|
path (car packet))))
|
|
(lambda ()
|
|
(action path full-path))))))
|
|
|
|
(define handle-dele
|
|
(make-file-action-handler
|
|
"Could not delete \"~A\": ~A."
|
|
(lambda (path full-path)
|
|
(delete-file full-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)
|
|
(let* ((info (file-info full-path))
|
|
(the-date (date (file-info:mtime info) 0)))
|
|
(register-reply! 213
|
|
(format-date "~Y~m~d~H~M~S" the-date))))))
|
|
|
|
(define handle-mkd
|
|
(make-file-action-handler
|
|
"Could not make directory \"~A\": ~A."
|
|
(lambda (path full-path)
|
|
(create-directory full-path #o755)
|
|
(register-reply! 257
|
|
(format #f "Created directory \"~A\"." path)))))
|
|
|
|
(define handle-rmd
|
|
(make-file-action-handler
|
|
"Could not remove directory \"~A\": ~A."
|
|
(lambda (path full-path)
|
|
(delete-directory full-path)
|
|
(register-reply! 250
|
|
(format #f "Deleted directory \"~A\"." path)))))
|
|
|
|
|
|
(define handle-rnfr
|
|
(make-file-action-handler
|
|
"Could not get info on file \"~A\": ~A."
|
|
(lambda (path full-path)
|
|
(file-info full-path)
|
|
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
|
|
(set-session-to-be-renamed full-path))))
|
|
|
|
(define (handle-rnto path)
|
|
(ensure-authenticated-login)
|
|
(if (not (session-to-be-renamed))
|
|
(signal-error! 503 "Need RNFR before RNTO."))
|
|
(if (string=? "" path)
|
|
(signal-error! 500 "No argument."))
|
|
(let ((full-path (string-append (session-root-directory)
|
|
(assemble-path path))))
|
|
|
|
(if (file-exists? full-path)
|
|
(signal-error!
|
|
550
|
|
(format #f "Rename failed---\"~A\" already exists or is protected."
|
|
path)))
|
|
|
|
(with-errno-handler*
|
|
(lambda (errno packet)
|
|
(signal-error! 550
|
|
(format #f "Could not rename: ~A." path)))
|
|
(lambda ()
|
|
(rename-file 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)
|
|
(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)))))))
|
|
|
|
|
|
(define (handle-type arg)
|
|
(cond
|
|
((string-ci=? "A" arg)
|
|
(set-session-type 'ascii))
|
|
((string-ci=? "I" arg)
|
|
(set-session-type 'image))
|
|
((string-ci=? "L8" arg)
|
|
(set-session-type 'image))
|
|
(else
|
|
(signal-error! 504
|
|
(format #f "Unknown TYPE: ~A." arg))))
|
|
|
|
(register-reply! 200
|
|
(format #f "TYPE is now ~A."
|
|
(case (session-type)
|
|
((ascii) "ASCII")
|
|
((image) "8-bit binary")
|
|
(else "somethin' weird, man")))))
|
|
|
|
(define (handle-mode arg)
|
|
(cond
|
|
((string=? "" arg)
|
|
(register-reply! 500
|
|
"No arguments. Not to worry---I'd ignore them anyway."))
|
|
((string-ci=? "S" arg)
|
|
(register-reply! 200 "Using stream mode to transfer files."))
|
|
(else
|
|
(register-reply! 504 (format #f "Mode \"~A\" is not supported."
|
|
arg)))))
|
|
|
|
(define (handle-stru arg)
|
|
(cond
|
|
((string=? "" arg)
|
|
(register-reply! 500
|
|
"No arguments. Not to worry---I'd ignore them anyway."))
|
|
((string-ci=? "F" arg)
|
|
(register-reply! 200 "Using file structure to transfer files."))
|
|
(else
|
|
(register-reply! 504
|
|
(format #f "File structure \"~A\" is not supported."
|
|
arg)))))
|
|
|
|
(define (handle-noop arg)
|
|
(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)
|
|
(cond
|
|
((regexp-exec *port-arg-regexp* string)
|
|
=> (lambda (match)
|
|
(let ((components
|
|
(map (lambda (match-index)
|
|
(string->number
|
|
(match:substring match match-index)))
|
|
'(1 2 3 4 5 6))))
|
|
(if (any? (lambda (component)
|
|
(> component 255))
|
|
components)
|
|
(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)))
|
|
components))))
|
|
(else
|
|
(signal-error! 500
|
|
"Syntax error in argument to PORT."))))
|
|
|
|
|
|
(define (handle-port stuff)
|
|
(ensure-authenticated-login)
|
|
(maybe-close-data-connection)
|
|
(call-with-values
|
|
(lambda () (parse-port-arg stuff))
|
|
(lambda (address port)
|
|
(let ((socket (create-socket protocol-family/internet
|
|
socket-type/stream)))
|
|
|
|
(set-socket-option socket level/socket socket/reuse-address #t)
|
|
|
|
(connect-socket socket
|
|
(internet-address->socket-address
|
|
address port))
|
|
|
|
(set-session-data-socket socket)
|
|
|
|
(register-reply! 200
|
|
(format #f "Connected to ~A, port ~A."
|
|
(format-internet-host-address address)
|
|
port))))))
|
|
|
|
|
|
(define (handle-pasv stuff)
|
|
(ensure-authenticated-login)
|
|
(maybe-close-data-connection)
|
|
(let ((socket (create-socket protocol-family/internet
|
|
socket-type/stream)))
|
|
|
|
(set-socket-option socket level/socket socket/reuse-address #t)
|
|
|
|
;; kludge
|
|
(bind-socket socket
|
|
(internet-address->socket-address (this-host-address)
|
|
0))
|
|
(listen-socket socket 1)
|
|
|
|
(let ((address (socket-local-address socket)))
|
|
|
|
(call-with-values
|
|
(lambda () (socket-address->internet-address address))
|
|
(lambda (host-address port)
|
|
|
|
(set-session-passive-socket socket)
|
|
|
|
(register-reply! 227
|
|
(format #f "Passive mode OK (~A,~A)"
|
|
(format-internet-host-address host-address ",")
|
|
(format-port port))))))))
|
|
|
|
; This doesn't look right. But I can't look into the socket of the
|
|
; control connection if we're running under inetd---there's no way to
|
|
; coerce a port to a socket as there is in C.
|
|
|
|
(define (this-host-address)
|
|
(car (host-info:addresses (host-info (system-name)))))
|
|
|
|
(define (format-internet-host-address address . maybe-separator)
|
|
(let ((separator (optional maybe-separator ".")))
|
|
(apply (lambda (b1 b2 b3 b4)
|
|
(string-append
|
|
b1 separator b2 separator
|
|
b3 separator b4))
|
|
(map number->string (internet-host-address-to-bytes address)))))
|
|
|
|
(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)
|
|
(handle-listing arg '()))
|
|
|
|
(define (handle-list arg)
|
|
(handle-listing arg '(long)))
|
|
|
|
(define (handle-listing arg preset-flags)
|
|
(ensure-authenticated-login)
|
|
(with-data-connection
|
|
(lambda ()
|
|
(let ((args (split-arguments arg)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(partition-list
|
|
(lambda (arg)
|
|
(and (not (string=? "" arg))
|
|
(char=? #\- (string-ref arg 0))))
|
|
args))
|
|
(lambda (flag-args rest-args)
|
|
|
|
(if (and (not (null? rest-args))
|
|
(not (null? (cdr rest-args))))
|
|
(signal-error! 501 "More than one path argument."))
|
|
|
|
(let ((path (if (null? rest-args)
|
|
""
|
|
(car rest-args)))
|
|
(flags (arguments->ls-flags flag-args)))
|
|
|
|
(if (not flags)
|
|
(signal-error! 501 "Invalid flag(s)."))
|
|
|
|
(generate-listing path (append preset-flags flags)))))))))
|
|
|
|
; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
|
|
; ENSURE-DATA-CONNECTION.
|
|
|
|
(define (generate-listing path flags)
|
|
(let ((full-path (string-append (session-root-directory)
|
|
(assemble-path path))))
|
|
(with-errno-handler*
|
|
(lambda (errno packet)
|
|
(signal-error! 451
|
|
(format #f "Can't access directory at ~A: ~A."
|
|
path
|
|
(car packet))))
|
|
(lambda ()
|
|
(with-cwd*
|
|
(file-name-directory full-path)
|
|
(lambda ()
|
|
(let ((nondir (file-name-nondirectory full-path)))
|
|
(ls flags
|
|
(list
|
|
;; work around OLIN BUG
|
|
(if (string=? nondir "")
|
|
"."
|
|
nondir))
|
|
(socket:outport (session-data-socket))))))))))
|
|
|
|
(define (handle-abor foo)
|
|
(maybe-close-data-connection)
|
|
(register-reply! 226 "Closing data connection."))
|
|
|
|
(define (handle-retr path)
|
|
(ensure-authenticated-login)
|
|
(let ((full-path (string-append (session-root-directory)
|
|
(assemble-path path))))
|
|
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
|
|
(lambda (condition more)
|
|
(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)))
|
|
(call-with-input-file full-path
|
|
(lambda (file-port)
|
|
(with-data-connection
|
|
(lambda ()
|
|
(case (session-type)
|
|
((image)
|
|
(copy-port->port-binary
|
|
file-port
|
|
(socket:outport (session-data-socket))))
|
|
((ascii)
|
|
(copy-port->port-ascii
|
|
file-port
|
|
(socket:outport (session-data-socket))))))))))))))
|
|
|
|
(define (handle-stor path)
|
|
(ensure-authenticated-login)
|
|
(let ((full-path (string-append (session-root-directory)
|
|
(assemble-path path))))
|
|
(with-fatal-error-handler*
|
|
(lambda (condition more)
|
|
(signal-error! 550
|
|
(format #f "Can't open \"~A\" for writing."
|
|
path)))
|
|
(lambda ()
|
|
(call-with-output-file full-path
|
|
(lambda (file-port)
|
|
(with-data-connection
|
|
(lambda ()
|
|
(case (session-type)
|
|
((image)
|
|
(copy-port->port-binary
|
|
(socket:inport (session-data-socket))
|
|
file-port))
|
|
((ascii)
|
|
(copy-ascii-port->port
|
|
(socket:inport (session-data-socket))
|
|
file-port)))))))))))
|
|
|
|
(define (assemble-path path)
|
|
(let* ((interim-path
|
|
(if (not (file-name-rooted? path))
|
|
(string-append (file-name-as-directory
|
|
(session-current-directory))
|
|
path)
|
|
path))
|
|
(complete-path (if (file-name-rooted? interim-path)
|
|
(file-name-sans-rooted interim-path)
|
|
interim-path)))
|
|
(cond
|
|
((normalize-path complete-path)
|
|
=> (lambda (assembled-path) assembled-path))
|
|
(else
|
|
(signal-error! 501 "Invalid pathname")))))
|
|
|
|
(define (ensure-authenticated-login)
|
|
(if (or (not (session-logged-in?))
|
|
(not (session-authenticated?)))
|
|
(signal-error! 530 "You're not logged in yet.")))
|
|
|
|
(define (with-data-connection thunk)
|
|
(dynamic-wind ensure-data-connection
|
|
thunk
|
|
maybe-close-data-connection))
|
|
|
|
(define *window-size* 51200)
|
|
|
|
(define (ensure-data-connection)
|
|
(if (and (not (session-data-socket))
|
|
(not (session-passive-socket)))
|
|
(signal-error! 425 "No data connection."))
|
|
|
|
(if (session-passive-socket)
|
|
(call-with-values
|
|
(lambda () (accept-connection (session-passive-socket)))
|
|
(lambda (socket socket-address)
|
|
(set-session-data-socket socket))))
|
|
|
|
(register-reply! 150 "Opening data connection.")
|
|
(write-replies)
|
|
|
|
(set-socket-option (session-data-socket) level/socket
|
|
socket/send-buffer *window-size*)
|
|
(set-socket-option (session-data-socket) level/socket
|
|
socket/receive-buffer *window-size*))
|
|
|
|
(define (maybe-close-data-connection)
|
|
(if (or (session-data-socket) (session-passive-socket))
|
|
(close-data-connection)))
|
|
|
|
(define (close-data-connection)
|
|
(if (session-data-socket)
|
|
(close-socket (session-data-socket)))
|
|
(if (session-passive-socket)
|
|
(close-socket (session-passive-socket)))
|
|
(register-reply! 226 "Closing data connection.")
|
|
(set-session-data-socket #f)
|
|
(set-session-passive-socket #f))
|
|
|
|
(define *command-alist*
|
|
(list
|
|
(cons "NOOP" handle-noop)
|
|
(cons "USER" handle-user)
|
|
(cons "PASS" handle-pass)
|
|
(cons "QUIT" handle-quit)
|
|
(cons "SYST" handle-syst)
|
|
(cons "CWD" handle-cwd)
|
|
(cons "PWD" handle-pwd)
|
|
(cons "CDUP" handle-cdup)
|
|
(cons "DELE" handle-dele)
|
|
(cons "MDTM" handle-mdtm)
|
|
(cons "MKD" handle-mkd)
|
|
(cons "RMD" handle-rmd)
|
|
(cons "RNFR" handle-rnfr)
|
|
(cons "RNTO" handle-rnto)
|
|
(cons "SIZE" handle-size)
|
|
(cons "TYPE" handle-type)
|
|
(cons "MODE" handle-mode)
|
|
(cons "STRU" handle-stru)
|
|
(cons "PORT" handle-port)
|
|
(cons "PASV" handle-pasv)
|
|
(cons "NLST" handle-nlst)
|
|
(cons "LIST" handle-list)
|
|
(cons "RETR" handle-retr)
|
|
(cons "STOR" handle-stor)
|
|
(cons "ABOR" handle-abor)))
|
|
|
|
(define (parse-command-line line)
|
|
(if (eof-object? line) ; Netscape does this
|
|
(values "QUIT" "")
|
|
(let* ((line (trim-spaces line))
|
|
(split-position (string-index line #\space)))
|
|
(if split-position
|
|
(values (upcase-string (substring line 0 split-position))
|
|
(trim-spaces (substring line
|
|
(+ 1 split-position)
|
|
(string-length line))))
|
|
(values (upcase-string line) "")))))
|
|
|
|
; Path names
|
|
|
|
; This removes all internal ..'s from a path.
|
|
; NORMALIZE-PATH returns #f if PATH points to a parent directory.
|
|
|
|
(define (normalize-path path)
|
|
(let loop ((components (split-file-name (simplify-file-name path)))
|
|
(reverse-result '()))
|
|
(cond
|
|
((null? components)
|
|
(path-list->file-name (reverse reverse-result)))
|
|
((null? (cdr components))
|
|
(if (string=? ".." (car components))
|
|
#f
|
|
(path-list->file-name
|
|
(reverse (cons (car components) reverse-result)))))
|
|
((string=? ".." (cadr components))
|
|
(loop (cddr components) reverse-result))
|
|
(else
|
|
(loop (cdr components) (cons (car components) reverse-result))))))
|
|
|
|
(define (file-name-rooted? file-name)
|
|
(and (not (string=? "" file-name))
|
|
(char=? #\/ (string-ref file-name 0))))
|
|
|
|
(define (file-name-sans-rooted file-name)
|
|
(substring file-name 1 (string-length file-name)))
|
|
|
|
(define split-arguments
|
|
(infix-splitter (make-regexp " +")))
|
|
|
|
; 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.
|
|
|
|
|
|
(define (write-replies)
|
|
(if (not (null? (session-reverse-replies)))
|
|
(let loop ((messages (reverse (session-reverse-replies))))
|
|
(if (null? (cdr messages))
|
|
(write-final-reply (car messages))
|
|
(begin
|
|
(write-nonfinal-reply (car messages))
|
|
(loop (cdr messages))))))
|
|
(set-session-reverse-replies '()))
|
|
|
|
(define (write-final-reply line)
|
|
(format (session-control-output-port) "~D ~A" (session-reply-code) line)
|
|
;; (format #t "Reply: ~D ~A~%" (session-reply-code) line)
|
|
(write-crlf (session-control-output-port)))
|
|
|
|
(define (write-nonfinal-reply line)
|
|
(format (session-control-output-port) "~D-~A" (session-reply-code) line)
|
|
;; (format #t "Reply: ~D-~A~%" (session-reply-code) line)
|
|
(write-crlf (session-control-output-port)))
|
|
|
|
(define (signal-error! code message)
|
|
(register-reply! code message)
|
|
(signal 'ftpd-error))
|
|
|
|
(define (register-reply! code message)
|
|
(set-session-reverse-replies
|
|
(cons message (session-reverse-replies)))
|
|
(set-session-reply-code code))
|
|
|
|
; Version
|
|
|
|
(define *ftpd-version* "$Revision: 1.8 $")
|
|
|
|
(define (copy-port->port-binary input-port output-port)
|
|
(let ((buffer (make-string *window-size*)))
|
|
(let loop ()
|
|
(cond
|
|
((read-string! buffer input-port)
|
|
=> (lambda (length)
|
|
(write-string buffer output-port 0 length)
|
|
(loop))))))
|
|
(force-output output-port))
|
|
|
|
(define (copy-port->port-ascii input-port output-port)
|
|
(let loop ()
|
|
(let ((line (read-line input-port 'concat)))
|
|
(if (not (eof-object? line))
|
|
(let ((length (string-length line)))
|
|
(cond
|
|
((zero? length)
|
|
'fick-dich-ins-knie)
|
|
((char=? #\newline (string-ref line (- length 1)))
|
|
(write-string line output-port 0 (- length 1))
|
|
(write-crlf output-port))
|
|
(else
|
|
(write-string line output-port)))
|
|
(loop)))))
|
|
(force-output output-port))
|
|
|
|
(define (copy-ascii-port->port input-port output-port)
|
|
(let loop ()
|
|
(let* ((line (read-crlf-line input-port
|
|
#f
|
|
90000 ; timeout
|
|
500)) ; max interval
|
|
(length (string-length line)))
|
|
(if (not (eof-object? line))
|
|
(begin
|
|
(write-string line output-port 0 length)
|
|
(newline output-port)
|
|
(loop)))))
|
|
(force-output output-port))
|
|
|
|
; Utilities
|
|
|
|
(define (optional maybe-arg default-exp)
|
|
(cond
|
|
((null? maybe-arg) default-exp)
|
|
((null? (cdr maybe-arg)) (car maybe-arg))
|
|
(else (error "too many optional arguments" maybe-arg))))
|
|
|
|
; Stuff from Big Scheme
|
|
; We can't open BIG-SCHEME because we use virgin SIGNALS. Sigh.
|
|
|
|
(define any? (structure-ref big-scheme any?))
|
|
(define partition-list (structure-ref big-scheme partition-list))
|