diff --git a/cgi-server.scm b/cgi-server.scm
index 12e3074..4c678a9 100644
--- a/cgi-server.scm
+++ b/cgi-server.scm
@@ -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))))
diff --git a/crlf-io.scm b/crlf-io.scm
index 19294b4..f2d4445 100644
--- a/crlf-io.scm
+++ b/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)))))))
+
+
diff --git a/ftpd.scm b/ftpd.scm
index b3e7e22..05b7614 100644
--- a/ftpd.scm
+++ b/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
- (lambda ()
+ (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)
- (display-banner)
- (handle-commands))))))
+ (let-fluid session (make-session input-port output-port)
+ (lambda ()
+ (display-banner)
+ (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)
- (call-with-values
- (lambda () (parse-command-line command-line))
- (lambda (command arg)
- (handle-command command arg)))))
+ (cond ((eq? command-line 'timeout)
+ (register-reply!
+ 421
+ "Timeout (900 seconds): closing control connection.")
+ (signal 'ftpd-quit))
+ (else
+ (call-with-values
+ (lambda () (parse-command-line command-line))
+ (lambda (command arg)
+ (handle-command command arg)))))))
(define (handle-command command arg)
(call-with-current-continuation
@@ -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,17 +482,13 @@
(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 ".")))
- (string-append
- (extract 24) separator (extract 16) separator
- (extract 8) separator (extract 0))))
-
+ (apply (lambda (b1 b2 b3 b4)
+ (string-append
+ b1 separator b2 separator
+ b3 separator b4))
+ (map number->string (internet-host-address-to-bytes address)))))
+
(define (format-port port)
(string-append
(number->string (bitwise-and (arithmetic-shift port -8) 255))
@@ -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
diff --git a/htmlout.scm b/htmlout.scm
index 523baa2..71d10d2 100644
--- a/htmlout.scm
+++ b/htmlout.scm
@@ -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))))
diff --git a/httpd-core.scm b/httpd-core.scm
index effb1a5..613c549 100644
--- a/httpd-core.scm
+++ b/httpd-core.scm
@@ -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?*
- (apply format *http-log-port* fmt args)
- (force-output *http-log-port*))))
+ (if *http-log?*
+ (begin
+ (apply format *http-log-port* fmt args)
+ (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 "~%~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
tag.
(for-each (lambda (x) (format out "
~s~%" x)) extras)
(write-string "\n" out)))
+ ; (force-output out) ;;; TODO check this
+ ; (flush-all-ports)
(force-output out)
; (if bkp? (breakpoint "http error"))
))
diff --git a/httpd-handlers.scm b/httpd-handlers.scm
index e5e54e7..84ad026 100644
--- a/httpd-handlers.scm
+++ b/httpd-handlers.scm
@@ -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,11 +175,11 @@
(http-error http-reply/bad-request req
"Indexed search not provided for this URL.")
- (? ((dotdot-check root file-path) =>
- (lambda (fname) (file-serve fname file-path req)))
- (else
- (http-error http-reply/bad-request req
- "URL contains unresolvable ..'s.")))))
+ (cond ((dotdot-check root file-path) =>
+ (lambda (fname) (file-serve fname file-path req)))
+ (else
+ (http-error http-reply/bad-request req
+ "URL contains unresolvable ..'s.")))))
;; Just (file-info fname) with error handling.
@@ -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 ""))))))
diff --git a/modules.scm b/modules.scm
index f10690a..287f29d 100644
--- a/modules.scm
+++ b/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))
diff --git a/parse-forms.scm b/parse-forms.scm
index 6eabc46..46f99c8 100644
--- a/parse-forms.scm
+++ b/parse-forms.scm
@@ -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,12 +45,14 @@
(define (parse-html-form-query q)
(let ((qlen (string-length q)))
(let recur ((i 0))
- (? ((index q #\= i) =>
- (lambda (j)
- (let ((k (or (index q #\& j) qlen)))
- (cons (cons (unescape-uri+ q i j)
- (unescape-uri+ q (+ j 1) k))
- (recur (+ k 1))))))
+ (cond
+ ((>= i qlen) '())
+ ((string-index q #\= i) =>
+ (lambda (j)
+ (let ((k (or (string-index q #\& j) qlen)))
+ (cons (cons (unescape-uri+ q i j)
+ (unescape-uri+ q (+ j 1) k))
+ (recur (+ k 1))))))
(else '()))))) ; BOGUS STRING -- Issue a warning.
diff --git a/rfc822.scm b/rfc822.scm
index 7334759..d5c629e 100644
--- a/rfc822.scm
+++ b/rfc822.scm
@@ -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.
diff --git a/uri.scm b/uri.scm
index 0abb714..136c1cb 100644
--- a/uri.scm
+++ b/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)))))