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

thread-support merged

This commit is contained in:
interp 2001-04-27 16:19:34 +00:00
parent 5862701455
commit 9692f2e8d3
10 changed files with 252 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
cgi-server.scm
View File

@ -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))))

16
crlf-io.scm
View File

@ -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)))))))

264
ftpd.scm
View File

@ -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

1
htmlout.scm
View File

@ -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))))

58
httpd-core.scm
View File

@ -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 "<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"))
))

20
httpd-handlers.scm
View File

@ -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 ""))))))

19
modules.scm
View File

@ -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))

16
parse-forms.scm
View File

@ -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.

2
rfc822.scm
View File

@ -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
View File

@ -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)))))