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

Clean up ftpd: 

- open fewer structures
- clarify relationship between OPTIONS and SESSION
- use an ordinary fluid for OPTIONS
- pass FTPD-OPTIONS record into FTPD instead of some random arguments
- ...
This commit is contained in:
sperber 2002-11-29 14:27:52 +00:00
parent cbb4609c3a
commit 4bf3bcb238
2 changed files with 362 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

621
scheme/ftpd/ftpd.scm
View File

@ -8,7 +8,7 @@
; It doesn't support the following desirable things: ; It doesn't support the following desirable things:
; ;
; - Login by user; this requires crypt which scsh doesn't have ; - Login by user
; - RESTART support ; - RESTART support
; - Banners from files on CWD ; - Banners from files on CWD
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/ ; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
@ -21,80 +21,192 @@
; "FILENAME does not exist" is much better. ; "FILENAME does not exist" is much better.
; - default value for ftpd should be looked up as in ftp.scm ; - default value for ftpd should be looked up as in ftp.scm
(define-record options (define-record-type ftpd-options :ftpd-options
logfile (really-make-ftpd-options port anonymous-home banner
logfile-lock logfile dns-lookup?)
dns-lookup?) ftpd-options?
(port ftpd-options-port set-ftpd-options-port!)
(anonymous-home ftpd-options-anonymous-home set-ftpd-options-anonymous-home!)
(banner ftpd-options-banner set-ftpd-options-banner!)
(logfile ftpd-options-logfile set-ftpd-options-logfile!)
(dns-lookup? ftpd-options-dns-lookup? set-ftpd-options-dns-lookup?!))
(define-record session (define (make-default-ftpd-options)
control-input-port (really-make-ftpd-options 21
control-output-port "~ftp"
anonymous-home (string-append "Scheme Untergrund ftp server (version "
(logged-in? #f) sunet-version-identifier
(authenticated? #f) ") ready.")
(anonymous? #f) #f
(root-directory #f) #f))
(current-directory "")
(to-be-renamed #f) (define (copy-ftpd-options options)
(reverse-replies '()) (really-make-ftpd-options (ftpd-options-port options)
(reply-code #f) ; the last one wins (ftpd-options-anonymous-home options)
(type 'ascii) ; PLEASE set this to bin (ftpd-options-banner options)
(data-socket #f) (ftpd-options-logfile options)
(passive-socket #f)) (ftpd-options-dns-lookup? options)))
(define (make-ftpd-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-ftpd-options (car stuff))
(make-default-ftpd-options))))
(set-option! new-options new-value)
new-options)))
(define with-port
(make-ftpd-options-transformer set-ftpd-options-port!))
(define with-anonymous-home
(make-ftpd-options-transformer set-ftpd-options-anonymous-home!))
(define with-banner
(make-ftpd-options-transformer set-ftpd-options-banner!))
(define with-logfile
(make-ftpd-options-transformer set-ftpd-options-logfile!))
(define with-dns-lookup?
(make-ftpd-options-transformer set-ftpd-options-dns-lookup?!))
(define (make-ftpd-options . stuff)
(let loop ((options (make-default-ftpd-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))
(define-record-type session :session
(really-make-session control-input-port
control-output-port
logfile-lock
logged-in?
authenticated?
anonymous?
root-directory
current-directory
to-be-renamed
reverse-replies
reply-code
type
data-socket
passive-socket)
session?
(control-input-port session-control-input-port
set-session-control-input-port!)
(control-output-port session-control-output-port
set-session-control-output-port!)
(logfile-lock session-logfile-lock)
(logged-in? session-logged-in?
set-session-logged-in?!)
(authenticated? session-authenticated?
set-session-authenticated?!)
(anonymous? session-anonymous?
set-session-anonymous?!)
(root-directory session-root-directory
set-session-root-directory!)
(current-directory session-current-directory
set-session-current-directory!)
(to-be-renamed session-to-be-renamed
set-session-to-be-renamed!)
(reverse-replies session-reverse-replies
set-session-reverse-replies!)
(reply-code session-reply-code
set-session-reply-code!)
(type session-type
set-session-type!)
(data-socket session-data-socket
set-session-data-socket!)
(passive-socket session-passive-socket
set-session-passive-socket!))
(define (make-session input-port output-port)
(really-make-session input-port output-port
(make-lock)
#f ; logged-in?
#f ; autenticated?
#f ; anonymous?
#f ; root-directory
"" ; current-directory
#f ; to-be-renamed
'() ; reverse-replies
#f ; reply-code
'ascii ; type
#f ; data-socket
#f ; passive-socket
))
(define session (make-fluid #f)) (define session (make-fluid #f))
(define options (make-preserved-thread-fluid (define options (make-fluid #f))
(make-options #f #f #f)))
(define (make-fluid-selector selector) (define (make-session-selector selector)
(lambda () (selector (fluid session)))) (lambda ()
(selector (fluid session))))
(define (make-fluid-setter setter) (define (make-session-modifier setter)
(lambda (value) (lambda (value)
(setter (fluid session) value))) (setter (fluid session) value)))
(define the-session-control-input-port
(make-session-selector session-control-input-port))
(define the-session-control-output-port
(make-session-selector session-control-output-port))
(define the-session-logfile-lock
(make-session-selector session-logfile-lock))
(define session-control-input-port (make-fluid-selector session:control-input-port)) (define the-session-logged-in? (make-session-selector session-logged-in?))
(define session-control-output-port (make-fluid-selector session:control-output-port)) (define the-session-authenticated? (make-session-selector session-authenticated?))
(define the-session-anonymous? (make-session-selector session-anonymous?))
(define the-session-root-directory (make-session-selector session-root-directory))
(define the-session-current-directory (make-session-selector session-current-directory))
(define the-session-to-be-renamed (make-session-selector session-to-be-renamed))
(define the-session-reverse-replies (make-session-selector session-reverse-replies))
(define the-session-reply-code (make-session-selector session-reply-code))
(define the-session-type (make-session-selector session-type))
(define the-session-data-socket (make-session-selector session-data-socket))
(define the-session-passive-socket (make-session-selector session-passive-socket))
(define session-anonymous-home (make-fluid-selector session:anonymous-home)) (define set-the-session-control-input-port!
(define session-logged-in? (make-fluid-selector session:logged-in?)) (make-session-modifier set-session-control-input-port!))
(define session-authenticated? (make-fluid-selector session:authenticated?)) (define set-the-session-control-output-port!
(define session-anonymous? (make-fluid-selector session:anonymous?)) (make-session-modifier set-session-control-output-port!))
(define session-root-directory (make-fluid-selector session:root-directory)) (define set-the-session-logged-in?!
(define session-current-directory (make-fluid-selector session:current-directory)) (make-session-modifier set-session-logged-in?!))
(define session-to-be-renamed (make-fluid-selector session:to-be-renamed)) (define set-the-session-authenticated?!
(define session-reverse-replies (make-fluid-selector session:reverse-replies)) (make-session-modifier set-session-authenticated?!))
(define session-reply-code (make-fluid-selector session:reply-code)) (define set-the-session-anonymous?!
(define session-type (make-fluid-selector session:type)) (make-session-modifier set-session-anonymous?!))
(define session-data-socket (make-fluid-selector session:data-socket)) (define set-the-session-root-directory!
(define session-passive-socket (make-fluid-selector session:passive-socket)) (make-session-modifier set-session-root-directory!))
(define set-the-session-current-directory!
(make-session-modifier set-session-current-directory!))
(define set-the-session-to-be-renamed!
(make-session-modifier set-session-to-be-renamed!))
(define set-the-session-reverse-replies!
(make-session-modifier set-session-reverse-replies!))
(define set-the-session-reply-code!
(make-session-modifier set-session-reply-code!))
(define set-the-session-type!
(make-session-modifier set-session-type!))
(define set-the-session-data-socket!
(make-session-modifier set-session-data-socket!))
(define set-the-session-passive-socket!
(make-session-modifier set-session-passive-socket!))
(define set-session-control-input-port (define (make-ftpd-options-selector selector)
(make-fluid-setter set-session:control-input-port)) (lambda ()
(define set-session-control-output-port (selector (fluid options))))
(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 (make-options-selector selector) (define the-ftpd-options-port
(lambda () (selector (thread-fluid options)))) (make-ftpd-options-selector ftpd-options-port))
;(define (make-options-setter setter) (define the-ftpd-options-anonymous-home
; (lambda (value) (make-ftpd-options-selector ftpd-options-anonymous-home))
; (setter (thread-fluid options)))) (define the-ftpd-options-banner
(make-ftpd-options-selector ftpd-options-banner))
(define options-logfile (make-options-selector options:logfile)) (define the-ftpd-options-logfile
(define options-logfile-lock (make-options-selector options:logfile-lock)) (make-ftpd-options-selector ftpd-options-logfile))
(define options-dns-lookup? (make-options-selector options:dns-lookup?)) (define the-ftpd-options-dns-lookup?
(make-ftpd-options-selector ftpd-options-dns-lookup?))
;;; LOG ------------------------------------------------------- ;;; LOG -------------------------------------------------------
(define (log level format-message . args) (define (log level format-message . args)
@ -143,37 +255,38 @@
; ;
(define file-log (define file-log
(let ((maybe-dns-lookup (lambda (ip) (let ((maybe-dns-lookup (lambda (ip)
(if (options-dns-lookup?) (if (the-ftpd-options-dns-lookup?)
(or (dns-lookup-ip ip) (or (dns-lookup-ip ip)
ip)) ip))
ip))) ip)))
(lambda (start-transfer-seconds info full-path direction) (lambda (start-transfer-seconds info full-path direction)
(if (options-logfile) (if (the-ftpd-options-logfile)
(begin (begin
(obtain-lock (options-logfile-lock)) (obtain-lock (the-session-logfile-lock))
(format (options-logfile) "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%" (format (the-ftpd-options-logfile)
(format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
(- (current-seconds) start-transfer-seconds) ; transfer time in secs (format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time
(- (current-seconds) start-transfer-seconds) ; transfer time in secs
(maybe-dns-lookup (maybe-dns-lookup
(socket-address->string (socket-address->string
(socket-remote-address (session-data-socket)) #f)) ; remote host ip (socket-remote-address (the-session-data-socket)) #f)) ; remote host ip
(file-info:size info) ; file size in bytes (file-info:size info) ; file size in bytes
(string-map (lambda (c) (string-map (lambda (c)
(if (eq? c #\space) #\_ c)) (if (eq? c #\space) #\_ c))
full-path) ; name of file (spaces replaced by "_") full-path) ; name of file (spaces replaced by "_")
(case (session-type) (case (the-session-type)
((ascii) "a") ((ascii) "a")
((image) "b") ((image) "b")
(else "?")) ; transfer type (else "?")) ; transfer type
direction ; incoming / outgoing file direction ; incoming / outgoing file
; anonymous access ; anonymous access
; password (no password given) ; password (no password given)
; service name ; service name
; authentication mode ; authentication mode
; authenticated user id' ; authenticated user id'
) )
(force-output (options-logfile)) (force-output (the-ftpd-options-logfile))
(release-lock (options-logfile-lock))))))) (release-lock (the-session-logfile-lock)))))))
(define (open-logfile logfile) (define (open-logfile logfile)
(with-errno-handler (with-errno-handler
@ -197,7 +310,8 @@
(else "unknown"))) (else "unknown")))
(define (socket->string socket) (define (socket->string socket)
(format #f "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A" (format #f
"family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A"
(protocol-family->string (socket:family socket)) (protocol-family->string (socket:family socket))
(socket-address->string (socket-local-address socket)) (socket-address->string (socket-local-address socket))
(socket-address->string (socket-remote-address socket)) (socket-address->string (socket-remote-address socket))
@ -207,110 +321,92 @@
;;; ftpd ------------------------------------------------------- ;;; ftpd -------------------------------------------------------
(define (ftpd anonymous-home . maybe-args) (define (ftpd ftpd-options)
(let-optionals maybe-args (display ">>>ftpd ") (write (list (ftpd-options-port ftpd-options))) (newline)
((port 21) (with-syslog-destination
(logfile #f) "ftpd"
(dns-lookup? #f)) #f
#f
#f
(lambda ()
(log (syslog-level notice)
"starting daemon on port ~D with ~S as anonymous home and logfile ~S"
(ftpd-options-port ftpd-options)
(expand-file-name (ftpd-options-anonymous-home ftpd-options)
(cwd))
(ftpd-options-logfile ftpd-options))
(let-thread-fluid options (bind-listen-accept-loop
(make-options (open-logfile logfile) protocol-family/internet
(make-lock) (lambda (socket address)
(and dns-lookup?)) (let ((remote-address (socket-address->string address)))
(lambda () (set-ftp-socket-options! socket)
(spawn
(with-syslog-destination (lambda ()
"ftpd" (handle-connection-encapsulated ftpd-options
#f socket
#f
#f
(lambda ()
(log (syslog-level notice)
"starting daemon on port ~D with ~S as anonymous home and logfile ~S"
port (expand-file-name anonymous-home (cwd)) logfile)
(bind-listen-accept-loop
protocol-family/internet
(lambda (socket address)
(let ((remote-address (socket-address->string address)))
(set-ftp-socket-options! socket)
(fork-thread
(spawn-to-handle-connection socket
address address
anonymous-home remote-address)))))
port (ftpd-options-port ftpd-options)))))
remote-address))))
port)))))))
(define (spawn-to-handle-connection socket address anonymous-home port remote-address) (define (handle-connection-encapsulated ftpd-options socket address remote-address)
(lambda () (call-with-current-continuation
(call-with-current-continuation (lambda (exit)
(lambda (exit) (with-errno-handler*
(with-errno-handler* (lambda (errno packet)
(lambda (errno packet) (log (syslog-level notice)
(log (syslog-level notice) "error with connection to ~A (~A)"
"error with connection to ~A (~A)" remote-address (car packet))
remote-address (car packet)) (exit 'fick-dich-ins-knie))
(exit 'fick-dich-ins-knie))
(lambda ()
(let ((socket-string (socket->string socket)))
(log (syslog-level notice)
"new connection to ~S"
remote-address)
(log (syslog-level debug) "socket: ~S" socket-string)
(dynamic-wind
(lambda () 'fick-dich-ins-knie)
(lambda ()
(handle-connection (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home)))
(lambda ()
(log (syslog-level debug)
"shutting down socket ~S"
socket-string)
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(log (syslog-level notice)
"error shutting down socket to ~A (~A)"
remote-address (car packet))
(exit 'fick-dich-ins-knie))
(lambda ()
(shutdown-socket socket shutdown/sends+receives)))))
(log (syslog-level notice)
"closing connection to ~A and finishing thread" remote-address)
(log (syslog-level debug)
"closing socket ~S" socket-string)
(close-socket socket))))))))))
(define (ftpd-inetd anonymous-home . maybe-args)
(let-optionals maybe-args
((logfile #f)
(dns-lookup? #f))
(let-thread-fluid options
(make-options (open-logfile logfile)
(make-lock)
(and dns-lookup?))
(lambda () (lambda ()
(let ((socket-string (socket->string socket)))
(with-syslog-destination (log (syslog-level notice)
"ftpd" "new connection to ~S"
#f remote-address)
#f
#f
(lambda ()
(log (syslog-level notice)
"starting ftpd from inetd"
(expand-file-name anonymous-home (cwd)))
(handle-connection (current-input-port) (log (syslog-level debug) "socket: ~S" socket-string)
(current-output-port)
(file-name-as-directory anonymous-home)))))))) (dynamic-wind
(lambda () 'fick-dich-ins-knie)
(lambda ()
(handle-connection ftpd-options
(socket:inport socket)
(socket:outport socket)))
(lambda ()
(log (syslog-level debug)
"shutting down socket ~S"
socket-string)
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(log (syslog-level notice)
"error shutting down socket to ~A (~A)"
remote-address (car packet))
(exit 'fick-dich-ins-knie))
(lambda ()
(shutdown-socket socket shutdown/sends+receives)))))
(log (syslog-level notice)
"closing connection to ~A and finishing thread" remote-address)
(log (syslog-level debug)
"closing socket ~S" socket-string)
(close-socket socket)))))))))
(define (ftpd-inetd ftpd-options)
(with-syslog-destination
"ftpd"
#f
#f
#f
(lambda ()
(log (syslog-level notice)
"starting ftpd from inetd"
(expand-file-name (ftpd-options-anonymous-home ftpd-options)
(cwd)))
(handle-connection ftpd-options
(current-input-port)
(current-output-port)))))
(define (set-ftp-socket-options! socket) (define (set-ftp-socket-options! socket)
;; If the client closes the connection, we won't lose when we try to ;; If the client closes the connection, we won't lose when we try to
@ -324,7 +420,7 @@
(set-socket-option socket level/socket socket/oob-inline #t)) (set-socket-option socket level/socket socket/oob-inline #t))
(define (handle-connection input-port output-port anonymous-home) (define (handle-connection ftpd-options input-port output-port)
(log (syslog-level debug) (log (syslog-level debug)
"handling connection with input port ~A, output port ~A" "handling connection with input port ~A, output port ~A"
input-port input-port
@ -339,20 +435,18 @@
(condition-stuff condition)) (condition-stuff condition))
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
(lambda () (lambda ()
(let-fluid session (make-session input-port output-port (let-fluids
anonymous-home) session (make-session input-port output-port)
(lambda () options ftpd-options
(display-banner) (lambda ()
(handle-commands)))))))) (display-banner)
(handle-commands))))))))
(define (display-banner) (define (display-banner)
(log (syslog-level debug) (log (syslog-level debug)
"displaying banner (220)") "displaying banner (220)")
(register-reply! 220 (register-reply! 220
(string-append (the-ftpd-options-banner)))
"Scheme Untergrund ftp server ("
*ftpd-version*
") ready.")))
(define-condition-type 'ftpd-quit '()) (define-condition-type 'ftpd-quit '())
(define ftpd-quit? (condition-predicate 'ftpd-quit)) (define ftpd-quit? (condition-predicate 'ftpd-quit))
@ -390,7 +484,7 @@
(define (accept-command) (define (accept-command)
(let* ((timeout-seconds 90) (let* ((timeout-seconds 90)
(command-line (read-crlf-line-timeout (session-control-input-port) (command-line (read-crlf-line-timeout (the-session-control-input-port)
#f #f
(* 1000 timeout-seconds);timeout (* 1000 timeout-seconds);timeout
500))) ; max interval 500))) ; max interval
@ -476,7 +570,7 @@
(define (handle-user name) (define (handle-user name)
(log-command (syslog-level info) "USER" name) (log-command (syslog-level info) "USER" name)
(cond (cond
((session-logged-in?) ((the-session-logged-in?)
(log (syslog-level info) "user ~S is already logged in (230)" (log (syslog-level info) "user ~S is already logged in (230)"
name) name)
(register-reply! 230 (register-reply! 230
@ -491,21 +585,22 @@
(define (handle-user-anonymous) (define (handle-user-anonymous)
(log (syslog-level info) "anonymous user login (230)") (log (syslog-level info) "anonymous user login (230)")
(set-session-logged-in? #t) (set-the-session-logged-in?! #t)
(set-session-authenticated? #t) (set-the-session-authenticated?! #t)
(set-session-anonymous? #t) (set-the-session-anonymous?! #t)
(set-session-root-directory (session-anonymous-home)) (set-the-session-root-directory!
(set-session-current-directory "") (file-name-as-directory (the-ftpd-options-anonymous-home)))
(set-the-session-current-directory! "")
(register-reply! 230 "Anonymous user logged in.")) (register-reply! 230 "Anonymous user logged in."))
(define (handle-pass password) (define (handle-pass password)
(log-command (syslog-level info) "PASS" password) (log-command (syslog-level info) "PASS" password)
(cond (cond
((not (session-logged-in?)) ((not (the-session-logged-in?))
(log (syslog-level info) "Rejecting password; user has not logged in yet. (530)") (log (syslog-level info) "Rejecting password; user has not logged in yet. (530)")
(register-reply! 530 "You have not logged in yet.")) (register-reply! 530 "You have not logged in yet."))
((session-anonymous?) ((the-session-anonymous?)
(log (syslog-level info) "Accepting password; user is logged in (200)") (log (syslog-level info) "Accepting password; user is logged in (200)")
(register-reply! 200 "Thank you.")) (register-reply! 200 "Thank you."))
(else (else
@ -526,7 +621,7 @@
(define (handle-cwd path) (define (handle-cwd path)
(log-command (syslog-level info) "CWD" path) (log-command (syslog-level info) "CWD" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((current-directory (assemble-path (session-current-directory) (let ((current-directory (assemble-path (the-session-current-directory)
path))) path)))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
@ -541,12 +636,12 @@
(lambda () (lambda ()
(with-cwd* (with-cwd*
(file-name-as-directory (file-name-as-directory
(string-append (session-root-directory) current-directory)) (string-append (the-session-root-directory) current-directory))
(lambda () ; I hate gratuitous syntax (lambda () ; I hate gratuitous syntax
(log (syslog-level debug) (log (syslog-level debug)
"changing current directory to \"/~A\" (250)" "changing current directory to \"/~A\" (250)"
current-directory) current-directory)
(set-session-current-directory current-directory) (set-the-session-current-directory! current-directory)
(register-reply! 250 (register-reply! 250
(format #f "Current directory changed to \"/~A\"." (format #f "Current directory changed to \"/~A\"."
current-directory)))))))) current-directory))))))))
@ -558,7 +653,7 @@
(define (handle-pwd foo) (define (handle-pwd foo)
(log-command (syslog-level info) "PWD") (log-command (syslog-level info) "PWD")
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((current-directory (session-current-directory))) (let ((current-directory (the-session-current-directory)))
(log (syslog-level info) "replying \"/~A\" as current directory (257)" (log (syslog-level info) "replying \"/~A\" as current directory (257)"
current-directory) current-directory)
(register-reply! 257 (register-reply! 257
@ -574,8 +669,8 @@
(log (syslog-level info) (log (syslog-level info)
"finishing processing command because of missing arguments (500)") "finishing processing command because of missing arguments (500)")
(signal-error! 500 "No argument."))) (signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (the-session-root-directory)
(assemble-path (session-current-directory) (assemble-path (the-session-current-directory)
path)))) path))))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
@ -644,12 +739,12 @@
(log (syslog-level debug) (log (syslog-level debug)
"RNFR-command accepted, waiting for RNTO-command (350)") "RNFR-command accepted, waiting for RNTO-command (350)")
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.") (register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
(set-session-to-be-renamed full-path)))) (set-the-session-to-be-renamed! full-path))))
(define (handle-rnto path) (define (handle-rnto path)
(log-command (syslog-level info) "RNTO" path) (log-command (syslog-level info) "RNTO" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(if (not (session-to-be-renamed)) (if (not (the-session-to-be-renamed))
(begin (begin
(log (syslog-level info) (log (syslog-level info)
"RNTO-command rejected: need RNFR-command before (503)") "RNTO-command rejected: need RNFR-command before (503)")
@ -659,8 +754,8 @@
(log (syslog-level info) (log (syslog-level info)
"No argument -- still waiting for (correct) RNTO-command (500)") "No argument -- still waiting for (correct) RNTO-command (500)")
(signal-error! 500 "No argument."))) (signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (the-session-root-directory)
(assemble-path (session-current-directory) (assemble-path (the-session-current-directory)
path)))) path))))
(if (file-exists? full-path) (if (file-exists? full-path)
@ -681,13 +776,13 @@
(signal-error! 550 (signal-error! 550
(format #f "Could not rename: ~A." path))) (format #f "Could not rename: ~A." path)))
(lambda () (lambda ()
(let ((old-name (session-to-be-renamed))) (let ((old-name (the-session-to-be-renamed)))
(rename-file old-name full-path) (rename-file old-name full-path)
(log (syslog-level debug) (log (syslog-level debug)
"~S renamed to ~S - no more waiting for RNTO-command (250)" "~S renamed to ~S - no more waiting for RNTO-command (250)"
old-name full-path) old-name full-path)
(register-reply! 250 "File renamed.") (register-reply! 250 "File renamed.")
(set-session-to-be-renamed #f)))))) (set-the-session-to-be-renamed! #f))))))
(define handle-size (define handle-size
(make-file-action-handler (make-file-action-handler
@ -716,13 +811,13 @@
(cond (cond
((string-ci=? "A" arg) ((string-ci=? "A" arg)
(log (syslog-level debug) "changed type to ascii (200)") (log (syslog-level debug) "changed type to ascii (200)")
(set-session-type 'ascii)) (set-the-session-type! 'ascii))
((string-ci=? "I" arg) ((string-ci=? "I" arg)
(log (syslog-level debug) "changed type to image (8-bit binary) (200)") (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
(set-session-type 'image)) (set-the-session-type! 'image))
((string-ci=? "L8" arg) ((string-ci=? "L8" arg)
(log (syslog-level debug) "changed type to image (8-bit binary) (200)") (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
(set-session-type 'image)) (set-the-session-type! 'image))
(else (else
(log (syslog-level info) (log (syslog-level info)
"rejecting TYPE-command: unknown type (504)") "rejecting TYPE-command: unknown type (504)")
@ -732,7 +827,7 @@
(log (syslog-level debug) "reporting new type (see above)") (log (syslog-level debug) "reporting new type (see above)")
(register-reply! 200 (register-reply! 200
(format #f "TYPE is now ~A." (format #f "TYPE is now ~A."
(case (session-type) (case (the-session-type)
((ascii) "ASCII") ((ascii) "ASCII")
((image) "8-bit binary") ((image) "8-bit binary")
(else "somethin' weird, man"))))) (else "somethin' weird, man")))))
@ -831,7 +926,7 @@
(internet-address->socket-address (internet-address->socket-address
address port)) address port))
(set-session-data-socket socket) (set-the-session-data-socket! socket)
(let ((formatted-internet-host-address (let ((formatted-internet-host-address
(format-internet-host-address address))) (format-internet-host-address address)))
@ -865,7 +960,7 @@
(lambda () (socket-address->internet-address address)) (lambda () (socket-address->internet-address address))
(lambda (host-address port) (lambda (host-address port)
(set-session-passive-socket socket) (set-the-session-passive-socket! socket)
(let ((formatted-this-host-address (let ((formatted-this-host-address
@ -882,7 +977,7 @@
(call-with-values (call-with-values
(lambda () (lambda ()
(socket-address->internet-address (socket-address->internet-address
(socket-local-address (port->socket (session-control-input-port) (socket-local-address (port->socket (the-session-control-input-port)
protocol-family/internet)))) protocol-family/internet))))
(lambda (host-address control-port) (lambda (host-address control-port)
host-address))) host-address)))
@ -935,8 +1030,8 @@
; ENSURE-DATA-CONNECTION. ; ENSURE-DATA-CONNECTION.
(define (generate-listing path flags) (define (generate-listing path flags)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (the-session-root-directory)
(assemble-path (session-current-directory) (assemble-path (the-session-current-directory)
path)))) path))))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
@ -962,7 +1057,7 @@
(if (string=? nondir "") (if (string=? nondir "")
"." "."
nondir)) nondir))
(socket:outport (session-data-socket)))))))))))) (socket:outport (the-session-data-socket))))))))))))
(define (handle-abor foo) (define (handle-abor foo)
(log-command (syslog-level info) "ABOR") (log-command (syslog-level info) "ABOR")
@ -973,8 +1068,8 @@
(define (handle-retr path) (define (handle-retr path)
(log-command (syslog-level info) "RETR" path) (log-command (syslog-level info) "RETR" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (the-session-root-directory)
(assemble-path (session-current-directory) (assemble-path (the-session-current-directory)
path)))) path))))
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO (with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
(lambda (condition more) (lambda (condition more)
@ -999,7 +1094,7 @@
(lambda (file-port) (lambda (file-port)
(with-data-connection (with-data-connection
(lambda () (lambda ()
(case (session-type) (case (the-session-type)
((image) ((image)
(log (syslog-level debug) (log (syslog-level debug)
"sending file ~S (binary mode)" "sending file ~S (binary mode)"
@ -1007,14 +1102,14 @@
(log (syslog-level debug) "sending is from port ~S" file-port) (log (syslog-level debug) "sending is from port ~S" file-port)
(copy-port->port-binary (copy-port->port-binary
file-port file-port
(socket:outport (session-data-socket)))) (socket:outport (the-session-data-socket))))
((ascii) ((ascii)
(log (syslog-level debug) "sending file ~S (ascii mode)" (log (syslog-level debug) "sending file ~S (ascii mode)"
full-path) full-path)
(log (syslog-level debug) "sending is from port ~S" file-port) (log (syslog-level debug) "sending is from port ~S" file-port)
(copy-port->port-ascii (copy-port->port-ascii
file-port file-port
(socket:outport (session-data-socket))))) (socket:outport (the-session-data-socket)))))
(file-log start-transfer-seconds info full-path "o")))))))))) (file-log start-transfer-seconds info full-path "o"))))))))))
(define (current-seconds) (define (current-seconds)
@ -1023,8 +1118,8 @@
(define (handle-stor path) (define (handle-stor path)
(log-command (syslog-level info) "STOR" path) (log-command (syslog-level info) "STOR" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (the-session-root-directory)
(assemble-path (session-current-directory) (assemble-path (the-session-current-directory)
path)))) path))))
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (condition more) (lambda (condition more)
@ -1038,8 +1133,8 @@
(lambda (file-port) (lambda (file-port)
(with-data-connection (with-data-connection
(lambda () (lambda ()
(let ((inport (socket:inport (session-data-socket)))) (let ((inport (socket:inport (the-session-data-socket))))
(case (session-type) (case (the-session-type)
((image) ((image)
(log (syslog-level notice) (log (syslog-level notice)
"storing data to ~S (binary mode)" "storing data to ~S (binary mode)"
@ -1048,7 +1143,7 @@
"storing comes from socket-inport ~S (binary-mode)" "storing comes from socket-inport ~S (binary-mode)"
inport) inport)
(copy-port->port-binary (copy-port->port-binary
(socket:inport (session-data-socket)) (socket:inport (the-session-data-socket))
file-port)) file-port))
((ascii) ((ascii)
(log (syslog-level notice) (log (syslog-level notice)
@ -1058,7 +1153,7 @@
"storing comes from socket-inport ~S (ascii-mode)" "storing comes from socket-inport ~S (ascii-mode)"
inport) inport)
(copy-ascii-port->port (copy-ascii-port->port
(socket:inport (session-data-socket)) (socket:inport (the-session-data-socket))
file-port))) file-port)))
(file-log start-transfer-seconds (file-info full-path) full-path "i") (file-log start-transfer-seconds (file-info full-path) full-path "i")
)))))))))) ))))))))))
@ -1085,8 +1180,8 @@
(signal-error! 501 "Invalid pathname"))))) (signal-error! 501 "Invalid pathname")))))
(define (ensure-authenticated-login) (define (ensure-authenticated-login)
(if (or (not (session-logged-in?)) (if (or (not (the-session-logged-in?))
(not (session-authenticated?))) (not (the-session-authenticated?)))
(begin (begin
(log (syslog-level debug) (log (syslog-level debug)
"login authentication failed - user is not logged in (530)") "login authentication failed - user is not logged in (530)")
@ -1101,40 +1196,40 @@
(define *window-size* 51200) (define *window-size* 51200)
(define (ensure-data-connection) (define (ensure-data-connection)
(if (and (not (session-data-socket)) (if (and (not (the-session-data-socket))
(not (session-passive-socket))) (not (the-session-passive-socket)))
(begin (begin
(log (syslog-level debug) "no data connection (425)") (log (syslog-level debug) "no data connection (425)")
(signal-error! 425 "No data connection."))) (signal-error! 425 "No data connection.")))
(if (session-passive-socket) (if (the-session-passive-socket)
(call-with-values (call-with-values
(lambda () (accept-connection (session-passive-socket))) (lambda () (accept-connection (the-session-passive-socket)))
(lambda (socket socket-address) (lambda (socket socket-address)
(set-session-data-socket socket)))) (set-the-session-data-socket! socket))))
(log (syslog-level debug) "opening data connection (150)") (log (syslog-level debug) "opening data connection (150)")
(register-reply! 150 "Opening data connection.") (register-reply! 150 "Opening data connection.")
(write-replies) (write-replies)
(set-socket-option (session-data-socket) level/socket (set-socket-option (the-session-data-socket) level/socket
socket/send-buffer *window-size*) socket/send-buffer *window-size*)
(set-socket-option (session-data-socket) level/socket (set-socket-option (the-session-data-socket) level/socket
socket/receive-buffer *window-size*)) socket/receive-buffer *window-size*))
(define (maybe-close-data-connection) (define (maybe-close-data-connection)
(if (or (session-data-socket) (session-passive-socket)) (if (or (the-session-data-socket) (the-session-passive-socket))
(close-data-connection))) (close-data-connection)))
(define (close-data-connection) (define (close-data-connection)
(if (session-data-socket) (if (the-session-data-socket)
(close-socket (session-data-socket))) (close-socket (the-session-data-socket)))
(if (session-passive-socket) (if (the-session-passive-socket)
(close-socket (session-passive-socket))) (close-socket (the-session-passive-socket)))
(log (syslog-level debug) "closing data connection (226)") (log (syslog-level debug) "closing data connection (226)")
(register-reply! 226 "Closing data connection.") (register-reply! 226 "Closing data connection.")
(set-session-data-socket #f) (set-the-session-data-socket! #f)
(set-session-passive-socket #f)) (set-the-session-passive-socket! #f))
(define *command-alist* (define *command-alist*
(list (list
@ -1214,38 +1309,34 @@
(define (write-replies) (define (write-replies)
(if (not (null? (session-reverse-replies))) (if (not (null? (the-session-reverse-replies)))
(let loop ((messages (reverse (session-reverse-replies)))) (let loop ((messages (reverse (the-session-reverse-replies))))
(if (null? (cdr messages)) (if (null? (cdr messages))
(write-final-reply (car messages)) (write-final-reply (car messages))
(begin (begin
(write-nonfinal-reply (car messages)) (write-nonfinal-reply (car messages))
(loop (cdr messages)))))) (loop (cdr messages))))))
(set-session-reverse-replies '())) (set-the-session-reverse-replies! '()))
(define (write-final-reply line) (define (write-final-reply line)
(format (session-control-output-port) "~D ~A" (session-reply-code) line) (format (the-session-control-output-port) "~D ~A" (the-session-reply-code) line)
(log (syslog-level debug) "Reply: ~D ~A~%" (session-reply-code) line) (log (syslog-level debug) "Reply: ~D ~A~%" (the-session-reply-code) line)
(write-crlf (session-control-output-port)) (write-crlf (the-session-control-output-port))
(force-output (session-control-output-port))) (force-output (the-session-control-output-port)))
(define (write-nonfinal-reply line) (define (write-nonfinal-reply line)
(format (session-control-output-port) "~D-~A" (session-reply-code) line) (format (the-session-control-output-port) "~D-~A" (the-session-reply-code) line)
(log (syslog-level debug) "Reply: ~D-~A~%" (session-reply-code) line) (log (syslog-level debug) "Reply: ~D-~A~%" (the-session-reply-code) line)
(write-crlf (session-control-output-port))) (write-crlf (the-session-control-output-port)))
(define (signal-error! code message) (define (signal-error! code message)
(register-reply! code message) (register-reply! code message)
(signal 'ftpd-error)) (signal 'ftpd-error))
(define (register-reply! code message) (define (register-reply! code message)
(set-session-reverse-replies (set-the-session-reverse-replies!
(cons message (session-reverse-replies))) (cons message (the-session-reverse-replies)))
(set-session-reply-code code)) (set-the-session-reply-code! code))
; Version
(define *ftpd-version* "$Revision: 1.8 $")
(define (copy-port->port-binary input-port output-port) (define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*))) (let ((buffer (make-string *window-size*)))
@ -1286,11 +1377,3 @@
(newline output-port) (newline output-port)
(loop))))) (loop)))))
(force-output output-port)) (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))))

21
scheme/packages.scm
View File

@ -241,7 +241,9 @@
;; FTP server ;; FTP server
(define-interface ftpd-interface (define-interface ftpd-interface
(export ftpd (export with-port with-anonymous-home with-banner with-logfile with-dns-lookup?
make-ftpd-options
ftpd
ftpd-inetd)) ftpd-inetd))
;; Web server ;; Web server
@ -651,27 +653,22 @@
;; FTP server ;; FTP server
(define-structure ftpd ftpd-interface (define-structure ftpd ftpd-interface
(open (modify scheme (hide open-output-file)) (open scheme-with-scsh
(modify scsh (hide char-set:whitespace))
conditions handle signals conditions handle signals
structure-refs define-record-types
handle-fatal-error handle-fatal-error
threads threads-internal ; last one to get CURRENT-THREAD threads threads-internal ; last one to get CURRENT-THREAD
locks
thread-fluids ; fork-thread
fluids fluids
srfi-14 locks
srfi-13 (subset srfi-13 (string-map string-trim-both string-index))
big-util (subset big-util (any? partition-list))
defrec-package
crlf-io crlf-io
ls ls
dns dns
sunet-version
sunet-utilities sunet-utilities
let-opt
receiving ; RECEIVE receiving ; RECEIVE
format-net) ; pretty print of internet-addresses format-net) ; pretty print of internet-addresses
(access big-scheme)
(files (ftpd ftpd))) (files (ftpd ftpd)))
;; Web server ;; Web server