thread-support merged
This commit is contained in:
interp
parent
5862701455
commit
9692f2e8d3
|
|
@ -99,7 +99,7 @@
|
|||
(nph? (string-suffix? "-nph" prog)) ; PROG end in "-nph" ?
|
||||
|
||||
(search (http-url:search (request:url req))) ; Compute the
|
||||
(argv (if (and search (not (index search #\=))) ; argv list.
|
||||
(argv (if (and search (not (string-index search #\=))) ; argv list.
|
||||
(split-and-decode-search-spec search)
|
||||
'()))
|
||||
|
||||
|
|
@ -125,7 +125,7 @@
|
|||
|
||||
(define (split-and-decode-search-spec s)
|
||||
(let recur ((i 0))
|
||||
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(? ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(recur (+ j 1)))))
|
||||
(else (list (unescape-uri s i (string-length s)))))))
|
||||
|
||||
|
|
@ -182,7 +182,7 @@
|
|||
("SCRIPT_NAME" . ,script-name)
|
||||
|
||||
("REMOTE_HOST" . ,(host-info:name (host-info raddr)))
|
||||
("REMOTE_ADDR" . ,(internet-address->dotted-string rhost))
|
||||
("REMOTE_ADDR" . ,(internet-host-address->dotted-string rhost))
|
||||
|
||||
;; ("AUTH_TYPE" . xx) ; Random authentication
|
||||
;; ("REMOTE_USER" . xx) ; features I don't understand.
|
||||
|
|
@ -265,15 +265,3 @@
|
|||
(close-input-port script-port))))
|
||||
|
||||
|
||||
;;; This proc and its inverse should be in a general IP module.
|
||||
|
||||
(define (internet-address->dotted-string num32)
|
||||
(let* ((num24 (arithmetic-shift num32 -8))
|
||||
(num16 (arithmetic-shift num24 -8))
|
||||
(num08 (arithmetic-shift num16 -8))
|
||||
(byte0 (bitwise-and #b11111111 num08))
|
||||
(byte1 (bitwise-and #b11111111 num16))
|
||||
(byte2 (bitwise-and #b11111111 num24))
|
||||
(byte3 (bitwise-and #b11111111 num32)))
|
||||
(string-append (number->string byte0) "." (number->string byte1) "."
|
||||
(number->string byte2) "." (number->string byte3))))
|
||||
|
|
|
|||
14
crlf-io.scm
14
crlf-io.scm
|
|
@ -36,4 +36,18 @@
|
|||
(write-string "\r\n" port)
|
||||
(force-output port))
|
||||
|
||||
(define (read-crlf-line-timeout . args)
|
||||
(let-optionals args ((fd/port (current-input-port))
|
||||
(retain-crlf? #f)
|
||||
(timeout 8000)
|
||||
(max-interval 500))
|
||||
(let loop ((waited 0) (interval 100))
|
||||
(cond ((> waited timeout)
|
||||
'timeout)
|
||||
((char-ready? fd/port)
|
||||
(read-crlf-line fd/port retain-crlf?))
|
||||
(else (sleep interval)
|
||||
(loop (+ waited interval) (min (* interval 2)
|
||||
max-interval)))))))
|
||||
|
||||
|
||||
|
|
|
|||
250
ftpd.scm
250
ftpd.scm
|
|
@ -10,6 +10,62 @@
|
|||
; - 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
|
||||
|
|
@ -18,11 +74,10 @@
|
|||
|
||||
(set-ftp-socket-options! socket)
|
||||
|
||||
(fork
|
||||
(spawn
|
||||
(lambda ()
|
||||
(handle-connection (socket:inport socket)
|
||||
(socket:outport socket))
|
||||
(reap-zombies)
|
||||
(shutdown-socket socket shutdown/sends+receives))))
|
||||
|
||||
port)))
|
||||
|
|
@ -34,26 +89,23 @@
|
|||
(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-port-buffering (socket:outport socket) 'bufpol/none)
|
||||
|
||||
(set-socket-option socket level/socket socket/oob-inline #t))
|
||||
|
||||
; We're stateful anyway, so what the hell ...
|
||||
|
||||
(define *control-input-port* #f)
|
||||
(define *control-output-port* #f)
|
||||
|
||||
(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 ()
|
||||
(set! *control-input-port* input-port)
|
||||
(set! *control-output-port* output-port)
|
||||
(let-fluid session (make-session input-port output-port)
|
||||
(lambda ()
|
||||
(display-banner)
|
||||
(handle-commands))))))
|
||||
(handle-commands))))))))
|
||||
|
||||
(define (display-banner)
|
||||
(register-reply! 220
|
||||
|
|
@ -68,6 +120,7 @@
|
|||
(define-condition-type 'ftpd-error '())
|
||||
(define ftpd-error? (condition-predicate 'ftpd-error))
|
||||
|
||||
|
||||
(define (handle-commands)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
|
|
@ -81,12 +134,21 @@
|
|||
(loop)))))
|
||||
|
||||
(define (accept-command)
|
||||
(let ((command-line (read-crlf-line *control-input-port*)))
|
||||
(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)))))
|
||||
(handle-command command arg)))))))
|
||||
|
||||
(define (handle-command command arg)
|
||||
(call-with-current-continuation
|
||||
|
|
@ -125,15 +187,10 @@
|
|||
"."
|
||||
(format #f " (argument(s) \"~A\")." arg)))))))
|
||||
|
||||
(define *logged-in?* #f)
|
||||
(define *authenticated?* #f)
|
||||
(define *anonymous?* #f)
|
||||
(define *root-directory* #f)
|
||||
(define *current-directory* "")
|
||||
|
||||
(define (handle-user name)
|
||||
(cond
|
||||
(*logged-in?*
|
||||
((session-logged-in?)
|
||||
(register-reply! 230
|
||||
"You are already logged in."))
|
||||
((or (string=? "anonymous" name)
|
||||
|
|
@ -144,24 +201,24 @@
|
|||
"Only anonymous logins allowed."))))
|
||||
|
||||
(define (handle-user-anonymous)
|
||||
(let ((ftp-info (user-info "ftp")))
|
||||
(let ((ftp-info (user-info "gasbichl")))
|
||||
|
||||
(set-gid (user-info:gid ftp-info))
|
||||
(set-uid (user-info:uid ftp-info))
|
||||
|
||||
(set! *logged-in?* #t)
|
||||
(set! *authenticated?* #t)
|
||||
(set! *anonymous?* #t)
|
||||
(set! *root-directory* (file-name-as-directory (user-info:home-dir ftp-info)))
|
||||
(set! *current-directory* "")
|
||||
(set-session-logged-in? #t)
|
||||
(set-session-authenticated? #t)
|
||||
(set-session-anonymous? #t)
|
||||
(set-session-root-directory (file-name-as-directory (user-info:home-dir ftp-info)))
|
||||
(set-session-current-directory "")
|
||||
|
||||
(register-reply! 230 "Anonymous user logged in.")))
|
||||
|
||||
(define (handle-pass password)
|
||||
(cond
|
||||
((not *logged-in?*)
|
||||
((not (session-logged-in?))
|
||||
(register-reply! 530 "You have not logged in yet."))
|
||||
(*anonymous?*
|
||||
((session-anonymous?)
|
||||
(register-reply! 200 "Thank you."))
|
||||
(else
|
||||
(register-reply! 502 "This can't happen."))))
|
||||
|
|
@ -185,9 +242,9 @@
|
|||
(lambda ()
|
||||
(with-cwd*
|
||||
(file-name-as-directory
|
||||
(string-append *root-directory* current-directory))
|
||||
(string-append (session-root-directory) current-directory))
|
||||
(lambda () ; I hate gratuitous syntax
|
||||
(set! *current-directory* current-directory)
|
||||
(set-session-current-directory current-directory)
|
||||
(register-reply! 250
|
||||
(format #f "Current directory changed to \"/~A\"."
|
||||
current-directory))))))))
|
||||
|
|
@ -199,7 +256,7 @@
|
|||
(ensure-authenticated-login)
|
||||
(register-reply! 257
|
||||
(format #f "Current directory is \"/~A\"."
|
||||
*current-directory*)))
|
||||
(session-current-directory))))
|
||||
|
||||
|
||||
(define (make-file-action-handler error-format-string action)
|
||||
|
|
@ -207,7 +264,7 @@
|
|||
(ensure-authenticated-login)
|
||||
(if (string=? "" path)
|
||||
(signal-error! 500 "No argument."))
|
||||
(let ((full-path (string-append *root-directory*
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
|
|
@ -249,7 +306,6 @@
|
|||
(register-reply! 250
|
||||
(format #f "Deleted directory \"~A\"." path)))))
|
||||
|
||||
(define *to-be-renamed* #f)
|
||||
|
||||
(define handle-rnfr
|
||||
(make-file-action-handler
|
||||
|
|
@ -257,15 +313,15 @@
|
|||
(lambda (path full-path)
|
||||
(file-info full-path)
|
||||
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
|
||||
(set! *to-be-renamed* full-path))))
|
||||
(set-session-to-be-renamed full-path))))
|
||||
|
||||
(define (handle-rnto path)
|
||||
(ensure-authenticated-login)
|
||||
(if (not *to-be-renamed*)
|
||||
(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 *root-directory*
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
|
||||
(if (file-exists? full-path)
|
||||
|
|
@ -279,9 +335,9 @@
|
|||
(signal-error! 550
|
||||
(format #f "Could not rename: ~A." path)))
|
||||
(lambda ()
|
||||
(rename-file *to-be-renamed* full-path)
|
||||
(rename-file full-path)
|
||||
(register-reply! 250 "File renamed.")
|
||||
(set! *to-be-renamed* #f)))))
|
||||
(set-session-to-be-renamed #f)))))
|
||||
|
||||
(define handle-size
|
||||
(make-file-action-handler
|
||||
|
|
@ -294,23 +350,22 @@
|
|||
path)))
|
||||
(register-reply! 213 (number->string (file-info:size info)))))))
|
||||
|
||||
(define *type* 'ascii)
|
||||
|
||||
(define (handle-type arg)
|
||||
(cond
|
||||
((string-ci=? "A" arg)
|
||||
(set! *type* 'ascii))
|
||||
(set-session-type 'ascii))
|
||||
((string-ci=? "I" arg)
|
||||
(set! *type* 'image))
|
||||
(set-session-type 'image))
|
||||
((string-ci=? "L8" arg)
|
||||
(set! *type* 'image))
|
||||
(set-session-type 'image))
|
||||
(else
|
||||
(signal-error! 504
|
||||
(format #f "Unknown TYPE: ~A." arg))))
|
||||
|
||||
(register-reply! 200
|
||||
(format #f "TYPE is now ~A."
|
||||
(case *type*
|
||||
(case (session-type)
|
||||
((ascii) "ASCII")
|
||||
((image) "8-bit binary")
|
||||
(else "somethin' weird, man")))))
|
||||
|
|
@ -360,10 +415,7 @@
|
|||
"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)
|
||||
(values (internet-host-address-from-bytes a1 a2 a3 a4)
|
||||
(+ (arithmetic-shift p1 8)
|
||||
p2)))
|
||||
components))))
|
||||
|
|
@ -371,7 +423,6 @@
|
|||
(signal-error! 500
|
||||
"Syntax error in argument to PORT."))))
|
||||
|
||||
(define *data-socket* #f)
|
||||
|
||||
(define (handle-port stuff)
|
||||
(ensure-authenticated-login)
|
||||
|
|
@ -388,14 +439,13 @@
|
|||
(internet-address->socket-address
|
||||
address port))
|
||||
|
||||
(set! *data-socket* socket)
|
||||
(set-session-data-socket socket)
|
||||
|
||||
(register-reply! 200
|
||||
(format #f "Connected to ~A, port ~A."
|
||||
(format-internet-host-address address)
|
||||
port))))))
|
||||
|
||||
(define *passive-socket* #f)
|
||||
|
||||
(define (handle-pasv stuff)
|
||||
(ensure-authenticated-login)
|
||||
|
|
@ -417,7 +467,7 @@
|
|||
(lambda () (socket-address->internet-address address))
|
||||
(lambda (host-address port)
|
||||
|
||||
(set! *passive-socket* socket)
|
||||
(set-session-passive-socket socket)
|
||||
|
||||
(register-reply! 227
|
||||
(format #f "Passive mode OK (~A,~A)"
|
||||
|
|
@ -432,16 +482,12 @@
|
|||
(car (host-info:addresses (host-info (system-name)))))
|
||||
|
||||
(define (format-internet-host-address address . maybe-separator)
|
||||
|
||||
(define (extract shift)
|
||||
(number->string
|
||||
(bitwise-and (arithmetic-shift address (- shift))
|
||||
255)))
|
||||
|
||||
(let ((separator (optional maybe-separator ".")))
|
||||
(apply (lambda (b1 b2 b3 b4)
|
||||
(string-append
|
||||
(extract 24) separator (extract 16) separator
|
||||
(extract 8) separator (extract 0))))
|
||||
b1 separator b2 separator
|
||||
b3 separator b4))
|
||||
(map number->string (internet-host-address-to-bytes address)))))
|
||||
|
||||
(define (format-port port)
|
||||
(string-append
|
||||
|
|
@ -487,7 +533,7 @@
|
|||
; ENSURE-DATA-CONNECTION.
|
||||
|
||||
(define (generate-listing path flags)
|
||||
(let ((full-path (string-append *root-directory*
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
|
|
@ -496,7 +542,8 @@
|
|||
path
|
||||
(car packet))))
|
||||
(lambda ()
|
||||
(ls flags (list full-path) (socket:outport *data-socket*))))))
|
||||
(ls flags (list full-path) (socket:outport
|
||||
(session-data-socket)))))))
|
||||
|
||||
(define (handle-abor foo)
|
||||
(maybe-close-data-connection)
|
||||
|
|
@ -504,7 +551,7 @@
|
|||
|
||||
(define (handle-retr path)
|
||||
(ensure-authenticated-login)
|
||||
(let ((full-path (string-append *root-directory*
|
||||
(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)
|
||||
|
|
@ -521,19 +568,19 @@
|
|||
(lambda (file-port)
|
||||
(with-data-connection
|
||||
(lambda ()
|
||||
(case *type*
|
||||
(case (session-type)
|
||||
((image)
|
||||
(copy-port->port-binary
|
||||
file-port
|
||||
(socket:outport *data-socket*)))
|
||||
(socket:outport (session-data-socket))))
|
||||
((ascii)
|
||||
(copy-port->port-ascii
|
||||
file-port
|
||||
(socket:outport *data-socket*)))))))))))))
|
||||
(socket:outport (session-data-socket))))))))))))))
|
||||
|
||||
(define (handle-stor path)
|
||||
(ensure-authenticated-login)
|
||||
(let ((full-path (string-append *root-directory*
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition more)
|
||||
|
|
@ -545,20 +592,21 @@
|
|||
(lambda (file-port)
|
||||
(with-data-connection
|
||||
(lambda ()
|
||||
(case *type*
|
||||
(case (session-type)
|
||||
((image)
|
||||
(copy-port->port-binary
|
||||
(socket:inport *data-socket*)
|
||||
(socket:inport (session-data-socket))
|
||||
file-port))
|
||||
((ascii)
|
||||
(copy-ascii-port->port
|
||||
(socket:inport *data-socket*)
|
||||
(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 *current-directory*)
|
||||
(string-append (file-name-as-directory
|
||||
(session-current-directory))
|
||||
path)
|
||||
path))
|
||||
(complete-path (if (file-name-rooted? interim-path)
|
||||
|
|
@ -571,8 +619,8 @@
|
|||
(signal-error! 501 "Invalid pathname")))))
|
||||
|
||||
(define (ensure-authenticated-login)
|
||||
(if (or (not *logged-in?*)
|
||||
(not *authenticated?*))
|
||||
(if (or (not (session-logged-in?))
|
||||
(not (session-authenticated?)))
|
||||
(signal-error! 530 "You're not logged in yet.")))
|
||||
|
||||
(define (with-data-connection thunk)
|
||||
|
|
@ -583,35 +631,36 @@
|
|||
(define *window-size* 51200)
|
||||
|
||||
(define (ensure-data-connection)
|
||||
(if (and (not *data-socket*) (not *passive-socket*))
|
||||
(if (and (not (session-data-socket))
|
||||
(not (session-passive-socket)))
|
||||
(signal-error! 425 "No data connection."))
|
||||
|
||||
(if *passive-socket*
|
||||
(if (session-passive-socket)
|
||||
(call-with-values
|
||||
(lambda () (accept-connection *passive-socket*))
|
||||
(lambda () (accept-connection (session-passive-socket)))
|
||||
(lambda (socket socket-address)
|
||||
(set! *data-socket* socket))))
|
||||
(set-session-data-socket socket))))
|
||||
|
||||
(register-reply! 150 "Opening data connection.")
|
||||
(write-replies)
|
||||
|
||||
(set-socket-option *data-socket* level/socket
|
||||
(set-socket-option (session-data-socket) level/socket
|
||||
socket/send-buffer *window-size*)
|
||||
(set-socket-option *data-socket* level/socket
|
||||
(set-socket-option (session-data-socket) level/socket
|
||||
socket/receive-buffer *window-size*))
|
||||
|
||||
(define (maybe-close-data-connection)
|
||||
(if (or *data-socket* *passive-socket*)
|
||||
(if (or (session-data-socket) (session-passive-socket))
|
||||
(close-data-connection)))
|
||||
|
||||
(define (close-data-connection)
|
||||
(if *data-socket*
|
||||
(close-socket *data-socket*))
|
||||
(if *passive-socket*
|
||||
(close-socket *passive-socket*))
|
||||
(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! *data-socket* #f)
|
||||
(set! *passive-socket* #f))
|
||||
(set-session-data-socket #f)
|
||||
(set-session-passive-socket #f))
|
||||
|
||||
(define *command-alist*
|
||||
(list
|
||||
|
|
@ -645,7 +694,7 @@
|
|||
(if (eof-object? line) ; Netscape does this
|
||||
(values "QUIT" "")
|
||||
(let* ((line (trim-spaces line))
|
||||
(split-position (index line #\space)))
|
||||
(split-position (string-index line #\space)))
|
||||
(if split-position
|
||||
(values (upcase-string (substring line 0 split-position))
|
||||
(trim-spaces (substring line
|
||||
|
|
@ -691,41 +740,39 @@
|
|||
; printed via WRITE-REPLIES. For the nature of the replies, see RFC
|
||||
; 959.
|
||||
|
||||
(define *reverse-replies* '())
|
||||
(define *reply-code* #f) ; the last one wins
|
||||
|
||||
(define (write-replies)
|
||||
(if (not (null? *reverse-replies*))
|
||||
(let loop ((messages (reverse *reverse-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! *reverse-replies* '()))
|
||||
(set-session-reverse-replies '()))
|
||||
|
||||
(define (write-final-reply line)
|
||||
(format *control-output-port* "~D ~A" *reply-code* line)
|
||||
;; (format #t "Reply: ~D ~A~%" *reply-code* line)
|
||||
(write-crlf *control-output-port*))
|
||||
(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 *control-output-port* "~D-~A" *reply-code* line)
|
||||
;; (format #t "Reply: ~D-~A~%" *reply-code* line)
|
||||
(write-crlf *control-output-port*))
|
||||
(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! *reverse-replies*
|
||||
(cons message *reverse-replies*))
|
||||
(set! *reply-code* code))
|
||||
(set-session-reverse-replies
|
||||
(cons message (session-reverse-replies)))
|
||||
(set-session-reply-code code))
|
||||
|
||||
; Version
|
||||
|
||||
(define *ftpd-version* "$Revision: 1.1 $")
|
||||
(define *ftpd-version* "$Revision: 1.2 $")
|
||||
|
||||
(define (copy-port->port-binary input-port output-port)
|
||||
(let ((buffer (make-string *window-size*)))
|
||||
|
|
@ -755,7 +802,10 @@
|
|||
|
||||
(define (copy-ascii-port->port input-port output-port)
|
||||
(let loop ()
|
||||
(let* ((line (read-crlf-line input-port))
|
||||
(let* ((line (read-crlf-line input-port
|
||||
#f
|
||||
90000 ; timeout
|
||||
500)) ; max interval
|
||||
(length (string-length line)))
|
||||
(if (not (eof-object? line))
|
||||
(begin
|
||||
|
|
|
|||
|
|
@ -120,6 +120,7 @@
|
|||
(apply emit-tag out tag attrs)
|
||||
(call-with-values thunk
|
||||
(lambda results
|
||||
(newline out)
|
||||
(emit-close-tag out tag)
|
||||
(apply values results))))
|
||||
|
||||
|
|
|
|||
|
|
@ -50,11 +50,13 @@
|
|||
|
||||
|
||||
(define *http-log?* #t)
|
||||
(define *http-log-port* (error-output-port))
|
||||
(define *http-log-port* (open-output-file "/tmp/bla"))
|
||||
(define (http-log fmt . args)
|
||||
(? (*http-log?*
|
||||
(if *http-log?*
|
||||
(begin
|
||||
(apply format *http-log-port* fmt args)
|
||||
(force-output *http-log-port*))))
|
||||
(force-output *http-log-port*)
|
||||
)))
|
||||
|
||||
|
||||
;;; (httpd path-handler [port server-root-dir])
|
||||
|
|
@ -74,21 +76,18 @@
|
|||
;; closes the connection, we won't lose when we try to close the
|
||||
;; socket by trying to flush the output buffer.
|
||||
(lambda (sock addr) ; Called once for every connection.
|
||||
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
|
||||
|
||||
(fork (lambda () ; Kill this line to bag forking.
|
||||
(let* ((i (dup->inport (socket:inport sock) 0))
|
||||
(o (dup->outport (socket:outport sock) 1)))
|
||||
(set-port-buffering i bufpol/none) ; Should propagate. ecch.
|
||||
(with-current-input-port i ; bind the
|
||||
(with-current-output-port o ; stdio ports, &
|
||||
(process-toplevel-request path-handler sock))) ; do it.
|
||||
(close-input-port i) ; Really only necessary
|
||||
(close-output-port o)))) ; for non-forking variant.
|
||||
|
||||
(reap-zombies) ; Clean up: reap dead children,
|
||||
(close-socket sock)) ; and close socket.
|
||||
(set-port-buffering (socket:outport sock) 'bufpol/none) ; No buffering
|
||||
|
||||
(spawn (lambda () ; Kill this line to bag forking.
|
||||
; Should propagate. ecch.
|
||||
(with-current-input-port
|
||||
(socket:inport sock) ; bind the
|
||||
(with-current-output-port
|
||||
(socket:outport sock) ; stdio ports, &
|
||||
(set-port-buffering (current-input-port) 'bufpol/none)
|
||||
(process-toplevel-request path-handler sock)
|
||||
(close-socket sock))) ; do it.
|
||||
)))
|
||||
port))))
|
||||
|
||||
;;; Top-level http request processor
|
||||
|
|
@ -141,6 +140,15 @@
|
|||
headers ; An rfc822 header alist (see rfc822.scm).
|
||||
socket) ; The socket connected to the client.
|
||||
|
||||
(define-record-discloser type/request
|
||||
(lambda (req)
|
||||
(list 'request
|
||||
(request:method req)
|
||||
(request:uri req)
|
||||
(request:url req)
|
||||
(request:version req)
|
||||
(request:headers req)
|
||||
(request:socket req))))
|
||||
;;; A http protocol version is an integer pair: (major . minor).
|
||||
|
||||
(define (version< v1 v2)
|
||||
|
|
@ -249,9 +257,9 @@
|
|||
|
||||
(define (string->words s)
|
||||
(let recur ((start 0))
|
||||
(? ((char-set-index s non-whitespace start) =>
|
||||
(cond ((char-set-index s non-whitespace start) =>
|
||||
(lambda (start)
|
||||
(? ((char-set-index s char-set:whitespace start) =>
|
||||
(cond ((char-set-index s char-set:whitespace start) =>
|
||||
(lambda (end)
|
||||
(cons (substring s start end)
|
||||
(recur end))))
|
||||
|
|
@ -351,6 +359,8 @@
|
|||
(apply really-send-http-error-reply reply-code req args))))
|
||||
|
||||
(define (really-send-http-error-reply reply-code req . args)
|
||||
(http-log "sending error-reply ~a ~%" reply-code)
|
||||
|
||||
(let* ((message (if (pair? args) (car args)))
|
||||
(extras (if (pair? args) (cdr args) '()))
|
||||
|
||||
|
|
@ -367,7 +377,7 @@
|
|||
(reply-code->text reply-code)
|
||||
new-protocol?)))
|
||||
|
||||
(do-msg (lambda () (? (message (display message out) (newline out))))))
|
||||
(do-msg (lambda () (cond (message (display message out) (newline out))))))
|
||||
|
||||
(if new-protocol? (begin-http-header out reply-code))
|
||||
|
||||
|
|
@ -423,7 +433,7 @@
|
|||
(if message (format out "<P>~%~a~%" message))))
|
||||
|
||||
((http-reply/internal-error)
|
||||
(format (error-output-port) "ERROR: ~A~%" message)
|
||||
(format (current-error-port) "ERROR: ~A~%" message)
|
||||
(when html-ok?
|
||||
(generic-title)
|
||||
(format out "The server encountered an internal error or
|
||||
|
|
@ -444,10 +454,12 @@ the requested method (~A).~%"
|
|||
|
||||
(else (if html-ok? (generic-title))))
|
||||
|
||||
(? (html-ok?
|
||||
(cond (html-ok?
|
||||
;; Output extra stuff and close the <body> tag.
|
||||
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" out)))
|
||||
; (force-output out) ;;; TODO check this
|
||||
; (flush-all-ports)
|
||||
(force-output out)
|
||||
; (if bkp? (breakpoint "http error"))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@
|
|||
|
||||
(define (alist-path-dispatcher handler-alist default-handler)
|
||||
(lambda (path req)
|
||||
(? ((and (pair? path) (assoc (car path) handler-alist)) =>
|
||||
(cond ((and (pair? path) (assoc (car path) handler-alist)) =>
|
||||
(lambda (entry) ((cdr entry) (cdr path) req)))
|
||||
(else (default-handler path req)))))
|
||||
|
||||
|
|
@ -175,7 +175,7 @@
|
|||
(http-error http-reply/bad-request req
|
||||
"Indexed search not provided for this URL.")
|
||||
|
||||
(? ((dotdot-check root file-path) =>
|
||||
(cond ((dotdot-check root file-path) =>
|
||||
(lambda (fname) (file-serve fname file-path req)))
|
||||
(else
|
||||
(http-error http-reply/bad-request req
|
||||
|
|
@ -309,14 +309,14 @@
|
|||
=> (lambda (open-match)
|
||||
(cond
|
||||
((regexp-exec title-close-tag-regexp stuff
|
||||
(match:end open-match))
|
||||
(match:end open-match 0))
|
||||
=> (lambda (close-match)
|
||||
(string-cut (substring stuff
|
||||
(match:end open-match)
|
||||
(match:start close-match))
|
||||
(match:end open-match 0)
|
||||
(match:start close-match 0))
|
||||
n)))
|
||||
(else (string-cut (substring stuff
|
||||
(match:end open-match)
|
||||
(match:end open-match 0)
|
||||
(string-length stuff))
|
||||
n)))))
|
||||
(else ""))))))
|
||||
|
|
|
|||
19
modules.scm
19
modules.scm
|
|
@ -34,11 +34,13 @@
|
|||
|
||||
|
||||
(define-structure crlf-io (export read-crlf-line
|
||||
read-crlf-line-timeout
|
||||
write-crlf)
|
||||
(open ascii ; ascii->char
|
||||
scsh ; read-line write-string force-output
|
||||
receiving ; MV return (RECEIVE and VALUES)
|
||||
let-opt ; let-optionals
|
||||
threads ; sleep
|
||||
scheme)
|
||||
(files crlf-io))
|
||||
|
||||
|
|
@ -64,6 +66,7 @@
|
|||
(open receiving ; MV return (RECEIVE and VALUES)
|
||||
condhax ; ? for COND
|
||||
scsh-utilities ; index
|
||||
string-lib
|
||||
let-opt ; let-optionals
|
||||
strings ; lowercase-string uppercase-string
|
||||
crlf-io ; read-crlf-line
|
||||
|
|
@ -96,6 +99,7 @@
|
|||
uri-path-list->path
|
||||
simplify-uri-path)
|
||||
(open scsh-utilities
|
||||
string-lib
|
||||
let-opt
|
||||
receiving
|
||||
condhax
|
||||
|
|
@ -142,6 +146,7 @@
|
|||
(open defrec-package
|
||||
receiving
|
||||
condhax
|
||||
string-lib
|
||||
char-set-package
|
||||
uri-package
|
||||
scsh-utilities
|
||||
|
|
@ -227,7 +232,8 @@
|
|||
|
||||
set-my-fqdn!
|
||||
set-my-port!)
|
||||
(open scsh
|
||||
(open threads
|
||||
scsh
|
||||
receiving
|
||||
let-opt
|
||||
crlf-io
|
||||
|
|
@ -237,6 +243,7 @@
|
|||
strings
|
||||
char-set-package
|
||||
defrec-package
|
||||
define-record-types
|
||||
handle
|
||||
conditions ; condition-stuff
|
||||
defenum-package
|
||||
|
|
@ -251,7 +258,7 @@
|
|||
|
||||
;;; For parsing submissions from HTML forms.
|
||||
(define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
|
||||
(open scsh scsh-utilities let-opt
|
||||
(open scsh scsh-utilities let-opt string-lib
|
||||
receiving uri-package strings condhax scheme)
|
||||
(files parse-forms))
|
||||
|
||||
|
|
@ -270,6 +277,7 @@
|
|||
cgi-handler
|
||||
initialise-request-invariant-cgi-env)
|
||||
(open strings
|
||||
string-lib
|
||||
rfc822
|
||||
crlf-io ; WRITE-CRLF
|
||||
uri-package
|
||||
|
|
@ -325,7 +333,6 @@
|
|||
htmlout-package
|
||||
conditions ; CONDITION-STUFF
|
||||
url-package ; HTTP-URL record type
|
||||
handle-fatal-error
|
||||
scheme)
|
||||
(files httpd-handlers))
|
||||
|
||||
|
|
@ -365,6 +372,7 @@
|
|||
find-info-file
|
||||
info-gateway-error)
|
||||
(open big-scheme
|
||||
string-lib
|
||||
conditions signals handle
|
||||
switch-syntax
|
||||
condhax
|
||||
|
|
@ -374,7 +382,6 @@
|
|||
httpd-error
|
||||
url-package
|
||||
uri-package
|
||||
handle-fatal-error
|
||||
scsh
|
||||
scheme)
|
||||
(files info-gateway))
|
||||
|
|
@ -416,6 +423,10 @@
|
|||
structure-refs
|
||||
handle-fatal-error
|
||||
scsh
|
||||
threads
|
||||
fluids
|
||||
string-lib
|
||||
defrec-package
|
||||
crlf-io strings ls)
|
||||
(access big-scheme)
|
||||
(files ftpd))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
|
||||
|
||||
;;; Imports and non-R4RS'isms
|
||||
;;; index (scsh)
|
||||
;;; string-index (string srfi)
|
||||
;;; let-optionals (let-opt package)
|
||||
;;; receive (Multiple-value return)
|
||||
;;; unescape-uri
|
||||
|
|
@ -45,9 +45,11 @@
|
|||
(define (parse-html-form-query q)
|
||||
(let ((qlen (string-length q)))
|
||||
(let recur ((i 0))
|
||||
(? ((index q #\= i) =>
|
||||
(cond
|
||||
((>= i qlen) '())
|
||||
((string-index q #\= i) =>
|
||||
(lambda (j)
|
||||
(let ((k (or (index q #\& j) qlen)))
|
||||
(let ((k (or (string-index q #\& j) qlen)))
|
||||
(cons (cons (unescape-uri+ q i j)
|
||||
(unescape-uri+ q (+ j 1) k))
|
||||
(recur (+ k 1))))))
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@
|
|||
|
||||
(values #f #f) ; Blank line or EOF terminates header text.
|
||||
|
||||
(? ((index line1 #\:) => ; Find the colon and
|
||||
(? ((string-index line1 #\:) => ; Find the colon and
|
||||
(lambda (colon) ; split out field name.
|
||||
(let ((name (string->symbol-pref (substring line1 0 colon))))
|
||||
;; Read in continuation lines.
|
||||
|
|
|
|||
9
uri.scm
9
uri.scm
|
|
@ -50,7 +50,11 @@
|
|||
;;; Returns four values: scheme, path, search, frag-id.
|
||||
;;; Each value is either #f or a string.
|
||||
|
||||
(define uri-reserved (string->char-set "=;/#?: "))
|
||||
|
||||
;;; MG: I think including = here will break up things, since it may be
|
||||
;;; part of the search string, preventing the ? to be found (+ and &
|
||||
;;; are excluded anyway).
|
||||
(define uri-reserved (string->char-set ";/#?: "))
|
||||
|
||||
(define (parse-uri s)
|
||||
(let* ((slen (string-length s))
|
||||
|
|
@ -68,7 +72,6 @@
|
|||
(ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
|
||||
|
||||
(path-end (or ques sharp slen)))
|
||||
|
||||
(values (and colon (substring s 0 colon))
|
||||
(split-uri-path s path-start path-end)
|
||||
(and ques (substring s (+ ques 1) (or sharp slen)))
|
||||
|
|
@ -231,7 +234,7 @@
|
|||
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
|
||||
(let split ((i start)) ; "" -> ("")
|
||||
(? ((>= i end) '(""))
|
||||
((index uri #\/ i) =>
|
||||
((string-index uri #\/ i) =>
|
||||
(lambda (slash)
|
||||
(cons (substring uri i slash)
|
||||
(split (+ slash 1)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue