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