sync with WSI branch
This commit is contained in:
parent
303c3343b3
commit
c4036bb8d0
|
@ -0,0 +1,42 @@
|
|||
SHELL = /bin/sh
|
||||
|
||||
version_id = 1.0
|
||||
|
||||
TEMPDIR = /tmp
|
||||
|
||||
sunet_files = ChangeLog \
|
||||
Readme \
|
||||
cgi-script.scm \
|
||||
cgi-server.scm \
|
||||
conditionals.scm \
|
||||
crlf-io.scm \
|
||||
htmlout.scm \
|
||||
http-top.scm \
|
||||
httpd-access-control.scm \
|
||||
httpd-core.scm \
|
||||
httpd-error.scm \
|
||||
httpd-handlers.scm \
|
||||
info-gateway.scm \
|
||||
rman-gateway.scm \
|
||||
modules.scm \
|
||||
parse-forms.scm \
|
||||
program-modules.scm \
|
||||
rfc822.scm \
|
||||
scheme-program-server.scm \
|
||||
server.scm \
|
||||
seval.scm \
|
||||
smtp.scm \
|
||||
stringhax.scm \
|
||||
su-httpd.txt \
|
||||
toothless.scm \
|
||||
uri.scm \
|
||||
url.scm
|
||||
|
||||
sunet-$(version_id).tar.gz: $(sunet_files)
|
||||
sunet_root=`pwd`; \
|
||||
mkdir $(TEMPDIR)/sunet-$(version_id); \
|
||||
cp $(sunet_files) $(TEMPDIR)/sunet-$(version_id); \
|
||||
cd $(TEMPDIR); \
|
||||
tar czf sunet-$(version_id).tar.gz sunet-$(version_id); \
|
||||
mv sunet-$(version_id).tar.gz $$sunet_root; \
|
||||
rm -rf sunet-$(version_id)
|
|
@ -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
16
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)))))))
|
||||
|
||||
|
||||
|
|
|
@ -0,0 +1,829 @@
|
|||
; RFC 959 ftp daemon
|
||||
|
||||
; Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
||||
; Copyright (c) 1998 Michael Sperber.
|
||||
|
||||
; It doesn't support the following desirable things:
|
||||
;
|
||||
; - Login by user; this requires crypt which scsh doesn't have
|
||||
; - RESTART support
|
||||
; - 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
|
||||
protocol-family/internet
|
||||
(lambda (socket address)
|
||||
|
||||
(set-ftp-socket-options! socket)
|
||||
|
||||
(spawn
|
||||
(lambda ()
|
||||
(handle-connection (socket:inport socket)
|
||||
(socket:outport socket))
|
||||
(shutdown-socket socket shutdown/sends+receives))))
|
||||
|
||||
port)))
|
||||
|
||||
(define (ftpd-inetd)
|
||||
(handle-connection (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
|
||||
;; close the socket by trying to flush the output buffer.
|
||||
(set-port-buffering (socket:outport socket) 'bufpol/none)
|
||||
|
||||
(set-socket-option socket level/socket socket/oob-inline #t))
|
||||
|
||||
|
||||
(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 ()
|
||||
(let-fluid session (make-session input-port output-port)
|
||||
(lambda ()
|
||||
(display-banner)
|
||||
(handle-commands))))))))
|
||||
|
||||
(define (display-banner)
|
||||
(register-reply! 220
|
||||
(string-append
|
||||
"Scheme Untergrund ftp server ("
|
||||
*ftpd-version*
|
||||
") ready.")))
|
||||
|
||||
(define-condition-type 'ftpd-quit '())
|
||||
(define ftpd-quit? (condition-predicate 'ftpd-quit))
|
||||
|
||||
(define-condition-type 'ftpd-error '())
|
||||
(define ftpd-error? (condition-predicate 'ftpd-error))
|
||||
|
||||
|
||||
(define (handle-commands)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
;; this in really only for ftpd-quit
|
||||
(write-replies)
|
||||
(more))
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(write-replies)
|
||||
(accept-command)
|
||||
(loop)))))
|
||||
|
||||
(define (accept-command)
|
||||
(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)))))))
|
||||
|
||||
(define (handle-command command arg)
|
||||
(call-with-current-continuation
|
||||
(lambda (escape)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(cond
|
||||
((error? condition)
|
||||
(register-reply! 451
|
||||
(format #f "Internal error: ~S"
|
||||
(condition-stuff condition)))
|
||||
(escape 'fick-dich-ins-knie))
|
||||
((ftpd-error? condition)
|
||||
(escape 'fick-dich-ins-knie))
|
||||
(else
|
||||
(more))))
|
||||
(lambda ()
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(register-reply! 451
|
||||
(format #f "Unix error: ~A." (car packet)))
|
||||
(escape 'fick-dich-ins-knie))
|
||||
(lambda ()
|
||||
(dispatch-command command arg))))))))
|
||||
|
||||
(define (dispatch-command command arg)
|
||||
(cond
|
||||
((assoc command *command-alist*)
|
||||
=> (lambda (pair)
|
||||
((cdr pair) arg)))
|
||||
(else
|
||||
(register-reply! 500
|
||||
(string-append
|
||||
(format #f "Unknown command: \"~A\"" command)
|
||||
(if (string=? "" arg)
|
||||
"."
|
||||
(format #f " (argument(s) \"~A\")." arg)))))))
|
||||
|
||||
|
||||
(define (handle-user name)
|
||||
(cond
|
||||
((session-logged-in?)
|
||||
(register-reply! 230
|
||||
"You are already logged in."))
|
||||
((or (string=? "anonymous" name)
|
||||
(string=? "ftp" name))
|
||||
(handle-user-anonymous))
|
||||
(else
|
||||
(register-reply! 530
|
||||
"Only anonymous logins allowed."))))
|
||||
|
||||
(define (handle-user-anonymous)
|
||||
(let ((ftp-info (user-info "gasbichl")))
|
||||
|
||||
(set-gid (user-info:gid ftp-info))
|
||||
(set-uid (user-info:uid ftp-info))
|
||||
|
||||
(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 (session-logged-in?))
|
||||
(register-reply! 530 "You have not logged in yet."))
|
||||
((session-anonymous?)
|
||||
(register-reply! 200 "Thank you."))
|
||||
(else
|
||||
(register-reply! 502 "This can't happen."))))
|
||||
|
||||
(define (handle-quit foo)
|
||||
(register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!")
|
||||
(signal 'ftpd-quit))
|
||||
|
||||
(define (handle-syst foo)
|
||||
(register-reply! 215 "UNIX Type: L8"))
|
||||
|
||||
(define (handle-cwd path)
|
||||
(ensure-authenticated-login)
|
||||
(let ((current-directory (assemble-path path)))
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(signal-error! 550
|
||||
(format #f "Can't change directory to \"~A\": ~A."
|
||||
path
|
||||
(car packet))))
|
||||
(lambda ()
|
||||
(with-cwd*
|
||||
(file-name-as-directory
|
||||
(string-append (session-root-directory) current-directory))
|
||||
(lambda () ; I hate gratuitous syntax
|
||||
(set-session-current-directory current-directory)
|
||||
(register-reply! 250
|
||||
(format #f "Current directory changed to \"/~A\"."
|
||||
current-directory))))))))
|
||||
|
||||
(define (handle-cdup foo)
|
||||
(handle-cwd ".."))
|
||||
|
||||
(define (handle-pwd foo)
|
||||
(ensure-authenticated-login)
|
||||
(register-reply! 257
|
||||
(format #f "Current directory is \"/~A\"."
|
||||
(session-current-directory))))
|
||||
|
||||
|
||||
(define (make-file-action-handler error-format-string action)
|
||||
(lambda (path)
|
||||
(ensure-authenticated-login)
|
||||
(if (string=? "" path)
|
||||
(signal-error! 500 "No argument."))
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(signal-error! 550
|
||||
(format #f error-format-string
|
||||
path (car packet))))
|
||||
(lambda ()
|
||||
(action path full-path))))))
|
||||
|
||||
(define handle-dele
|
||||
(make-file-action-handler
|
||||
"Could not delete \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(delete-file full-path)
|
||||
(register-reply! 250 (format #f "Deleted \"~A\"." path)))))
|
||||
|
||||
(define handle-mdtm
|
||||
(make-file-action-handler
|
||||
"Could not get info on \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(let* ((info (file-info full-path))
|
||||
(the-date (date (file-info:mtime info) 0)))
|
||||
(register-reply! 213
|
||||
(format-date "~Y~m~d~H~M~S" the-date))))))
|
||||
|
||||
(define handle-mkd
|
||||
(make-file-action-handler
|
||||
"Could not make directory \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(create-directory full-path #o755)
|
||||
(register-reply! 257
|
||||
(format #f "Created directory \"~A\"." path)))))
|
||||
|
||||
(define handle-rmd
|
||||
(make-file-action-handler
|
||||
"Could not remove directory \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(delete-directory full-path)
|
||||
(register-reply! 250
|
||||
(format #f "Deleted directory \"~A\"." path)))))
|
||||
|
||||
|
||||
(define handle-rnfr
|
||||
(make-file-action-handler
|
||||
"Could not get info on file \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(file-info full-path)
|
||||
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
|
||||
(set-session-to-be-renamed full-path))))
|
||||
|
||||
(define (handle-rnto path)
|
||||
(ensure-authenticated-login)
|
||||
(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 (session-root-directory)
|
||||
(assemble-path path))))
|
||||
|
||||
(if (file-exists? full-path)
|
||||
(signal-error!
|
||||
550
|
||||
(format #f "Rename failed---\"~A\" already exists or is protected."
|
||||
path)))
|
||||
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(signal-error! 550
|
||||
(format #f "Could not rename: ~A." path)))
|
||||
(lambda ()
|
||||
(rename-file full-path)
|
||||
(register-reply! 250 "File renamed.")
|
||||
(set-session-to-be-renamed #f)))))
|
||||
|
||||
(define handle-size
|
||||
(make-file-action-handler
|
||||
"Could not get info on file \"~A\": ~A."
|
||||
(lambda (path full-path)
|
||||
(let ((info (file-info full-path)))
|
||||
(if (not (eq? 'regular (file-info:type info)))
|
||||
(signal-error! 550
|
||||
(format #f "\"~A\" is not a regular file."
|
||||
path)))
|
||||
(register-reply! 213 (number->string (file-info:size info)))))))
|
||||
|
||||
|
||||
(define (handle-type arg)
|
||||
(cond
|
||||
((string-ci=? "A" arg)
|
||||
(set-session-type 'ascii))
|
||||
((string-ci=? "I" arg)
|
||||
(set-session-type 'image))
|
||||
((string-ci=? "L8" arg)
|
||||
(set-session-type 'image))
|
||||
(else
|
||||
(signal-error! 504
|
||||
(format #f "Unknown TYPE: ~A." arg))))
|
||||
|
||||
(register-reply! 200
|
||||
(format #f "TYPE is now ~A."
|
||||
(case (session-type)
|
||||
((ascii) "ASCII")
|
||||
((image) "8-bit binary")
|
||||
(else "somethin' weird, man")))))
|
||||
|
||||
(define (handle-mode arg)
|
||||
(cond
|
||||
((string=? "" arg)
|
||||
(register-reply! 500
|
||||
"No arguments. Not to worry---I'd ignore them anyway."))
|
||||
((string-ci=? "S" arg)
|
||||
(register-reply! 200 "Using stream mode to transfer files."))
|
||||
(else
|
||||
(register-reply! 504 (format #f "Mode \"~A\" is not supported."
|
||||
arg)))))
|
||||
|
||||
(define (handle-stru arg)
|
||||
(cond
|
||||
((string=? "" arg)
|
||||
(register-reply! 500
|
||||
"No arguments. Not to worry---I'd ignore them anyway."))
|
||||
((string-ci=? "F" arg)
|
||||
(register-reply! 200 "Using file structure to transfer files."))
|
||||
(else
|
||||
(register-reply! 504
|
||||
(format #f "File structure \"~A\" is not supported."
|
||||
arg)))))
|
||||
|
||||
(define (handle-noop arg)
|
||||
(register-reply! 200 "Done nothing, but successfully."))
|
||||
|
||||
(define *port-arg-regexp*
|
||||
(make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
|
||||
|
||||
(define (parse-port-arg string)
|
||||
(cond
|
||||
((regexp-exec *port-arg-regexp* string)
|
||||
=> (lambda (match)
|
||||
(let ((components
|
||||
(map (lambda (match-index)
|
||||
(string->number
|
||||
(match:substring match match-index)))
|
||||
'(1 2 3 4 5 6))))
|
||||
(if (any? (lambda (component)
|
||||
(> component 255))
|
||||
components)
|
||||
(signal-error! 501
|
||||
"Invalid arguments to PORT."))
|
||||
(apply
|
||||
(lambda (a1 a2 a3 a4 p1 p2)
|
||||
(values (internet-host-address-from-bytes a1 a2 a3 a4)
|
||||
(+ (arithmetic-shift p1 8)
|
||||
p2)))
|
||||
components))))
|
||||
(else
|
||||
(signal-error! 500
|
||||
"Syntax error in argument to PORT."))))
|
||||
|
||||
|
||||
(define (handle-port stuff)
|
||||
(ensure-authenticated-login)
|
||||
(maybe-close-data-connection)
|
||||
(call-with-values
|
||||
(lambda () (parse-port-arg stuff))
|
||||
(lambda (address port)
|
||||
(let ((socket (create-socket protocol-family/internet
|
||||
socket-type/stream)))
|
||||
|
||||
(set-socket-option socket level/socket socket/reuse-address #t)
|
||||
|
||||
(connect-socket socket
|
||||
(internet-address->socket-address
|
||||
address port))
|
||||
|
||||
(set-session-data-socket socket)
|
||||
|
||||
(register-reply! 200
|
||||
(format #f "Connected to ~A, port ~A."
|
||||
(format-internet-host-address address)
|
||||
port))))))
|
||||
|
||||
|
||||
(define (handle-pasv stuff)
|
||||
(ensure-authenticated-login)
|
||||
(maybe-close-data-connection)
|
||||
(let ((socket (create-socket protocol-family/internet
|
||||
socket-type/stream)))
|
||||
|
||||
(set-socket-option socket level/socket socket/reuse-address #t)
|
||||
|
||||
;; kludge
|
||||
(bind-socket socket
|
||||
(internet-address->socket-address (this-host-address)
|
||||
0))
|
||||
(listen-socket socket 1)
|
||||
|
||||
(let ((address (socket-local-address socket)))
|
||||
|
||||
(call-with-values
|
||||
(lambda () (socket-address->internet-address address))
|
||||
(lambda (host-address port)
|
||||
|
||||
(set-session-passive-socket socket)
|
||||
|
||||
(register-reply! 227
|
||||
(format #f "Passive mode OK (~A,~A)"
|
||||
(format-internet-host-address host-address ",")
|
||||
(format-port port))))))))
|
||||
|
||||
; This doesn't look right. But I can't look into the socket of the
|
||||
; control connection if we're running under inetd---there's no way to
|
||||
; coerce a port to a socket as there is in C.
|
||||
|
||||
(define (this-host-address)
|
||||
(car (host-info:addresses (host-info (system-name)))))
|
||||
|
||||
(define (format-internet-host-address address . maybe-separator)
|
||||
(let ((separator (optional maybe-separator ".")))
|
||||
(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))
|
||||
","
|
||||
(number->string (bitwise-and port 255))))
|
||||
|
||||
(define (handle-nlst arg)
|
||||
(handle-listing arg '()))
|
||||
|
||||
(define (handle-list arg)
|
||||
(handle-listing arg '(long)))
|
||||
|
||||
(define (handle-listing arg preset-flags)
|
||||
(ensure-authenticated-login)
|
||||
(with-data-connection
|
||||
(lambda ()
|
||||
(let ((args (split-arguments arg)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(partition-list
|
||||
(lambda (arg)
|
||||
(and (not (string=? "" arg))
|
||||
(char=? #\- (string-ref arg 0))))
|
||||
args))
|
||||
(lambda (flag-args rest-args)
|
||||
|
||||
(if (and (not (null? rest-args))
|
||||
(not (null? (cdr rest-args))))
|
||||
(signal-error! 501 "More than one path argument."))
|
||||
|
||||
(let ((path (if (null? rest-args)
|
||||
""
|
||||
(car rest-args)))
|
||||
(flags (arguments->ls-flags flag-args)))
|
||||
|
||||
(if (not flags)
|
||||
(signal-error! 501 "Invalid flag(s)."))
|
||||
|
||||
(generate-listing path (append preset-flags flags)))))))))
|
||||
|
||||
; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
|
||||
; ENSURE-DATA-CONNECTION.
|
||||
|
||||
(define (generate-listing path flags)
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(signal-error! 451
|
||||
(format #f "Can't access directory at ~A: ~A."
|
||||
path
|
||||
(car packet))))
|
||||
(lambda ()
|
||||
(ls flags (list full-path) (socket:outport
|
||||
(session-data-socket)))))))
|
||||
|
||||
(define (handle-abor foo)
|
||||
(maybe-close-data-connection)
|
||||
(register-reply! 226 "Closing data connection."))
|
||||
|
||||
(define (handle-retr path)
|
||||
(ensure-authenticated-login)
|
||||
(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)
|
||||
(signal-error! 550
|
||||
(format #f "Can't open \"~A\" for reading."
|
||||
path)))
|
||||
(lambda ()
|
||||
(let ((info (file-info full-path)))
|
||||
(if (not (eq? 'regular (file-info:type info)))
|
||||
(signal-error! 450
|
||||
(format #f "\"~A\" is not a regular file."
|
||||
path)))
|
||||
(call-with-input-file full-path
|
||||
(lambda (file-port)
|
||||
(with-data-connection
|
||||
(lambda ()
|
||||
(case (session-type)
|
||||
((image)
|
||||
(copy-port->port-binary
|
||||
file-port
|
||||
(socket:outport (session-data-socket))))
|
||||
((ascii)
|
||||
(copy-port->port-ascii
|
||||
file-port
|
||||
(socket:outport (session-data-socket))))))))))))))
|
||||
|
||||
(define (handle-stor path)
|
||||
(ensure-authenticated-login)
|
||||
(let ((full-path (string-append (session-root-directory)
|
||||
(assemble-path path))))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition more)
|
||||
(signal-error! 550
|
||||
(format #f "Can't open \"~A\" for writing."
|
||||
path)))
|
||||
(lambda ()
|
||||
(call-with-output-file full-path
|
||||
(lambda (file-port)
|
||||
(with-data-connection
|
||||
(lambda ()
|
||||
(case (session-type)
|
||||
((image)
|
||||
(copy-port->port-binary
|
||||
(socket:inport (session-data-socket))
|
||||
file-port))
|
||||
((ascii)
|
||||
(copy-ascii-port->port
|
||||
(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
|
||||
(session-current-directory))
|
||||
path)
|
||||
path))
|
||||
(complete-path (if (file-name-rooted? interim-path)
|
||||
(file-name-sans-rooted interim-path)
|
||||
interim-path)))
|
||||
(cond
|
||||
((normalize-path complete-path)
|
||||
=> (lambda (assembled-path) assembled-path))
|
||||
(else
|
||||
(signal-error! 501 "Invalid pathname")))))
|
||||
|
||||
(define (ensure-authenticated-login)
|
||||
(if (or (not (session-logged-in?))
|
||||
(not (session-authenticated?)))
|
||||
(signal-error! 530 "You're not logged in yet.")))
|
||||
|
||||
(define (with-data-connection thunk)
|
||||
(dynamic-wind ensure-data-connection
|
||||
thunk
|
||||
maybe-close-data-connection))
|
||||
|
||||
(define *window-size* 51200)
|
||||
|
||||
(define (ensure-data-connection)
|
||||
(if (and (not (session-data-socket))
|
||||
(not (session-passive-socket)))
|
||||
(signal-error! 425 "No data connection."))
|
||||
|
||||
(if (session-passive-socket)
|
||||
(call-with-values
|
||||
(lambda () (accept-connection (session-passive-socket)))
|
||||
(lambda (socket socket-address)
|
||||
(set-session-data-socket socket))))
|
||||
|
||||
(register-reply! 150 "Opening data connection.")
|
||||
(write-replies)
|
||||
|
||||
(set-socket-option (session-data-socket) level/socket
|
||||
socket/send-buffer *window-size*)
|
||||
(set-socket-option (session-data-socket) level/socket
|
||||
socket/receive-buffer *window-size*))
|
||||
|
||||
(define (maybe-close-data-connection)
|
||||
(if (or (session-data-socket) (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)))
|
||||
(register-reply! 226 "Closing data connection.")
|
||||
(set-session-data-socket #f)
|
||||
(set-session-passive-socket #f))
|
||||
|
||||
(define *command-alist*
|
||||
(list
|
||||
(cons "NOOP" handle-noop)
|
||||
(cons "USER" handle-user)
|
||||
(cons "PASS" handle-pass)
|
||||
(cons "QUIT" handle-quit)
|
||||
(cons "SYST" handle-syst)
|
||||
(cons "CWD" handle-cwd)
|
||||
(cons "PWD" handle-pwd)
|
||||
(cons "CDUP" handle-cdup)
|
||||
(cons "DELE" handle-dele)
|
||||
(cons "MDTM" handle-mdtm)
|
||||
(cons "MKD" handle-mkd)
|
||||
(cons "RMD" handle-rmd)
|
||||
(cons "RNFR" handle-rnfr)
|
||||
(cons "RNTO" handle-rnto)
|
||||
(cons "SIZE" handle-size)
|
||||
(cons "TYPE" handle-type)
|
||||
(cons "MODE" handle-mode)
|
||||
(cons "STRU" handle-stru)
|
||||
(cons "PORT" handle-port)
|
||||
(cons "PASV" handle-pasv)
|
||||
(cons "NLST" handle-nlst)
|
||||
(cons "LIST" handle-list)
|
||||
(cons "RETR" handle-retr)
|
||||
(cons "STOR" handle-stor)
|
||||
(cons "ABOR" handle-abor)))
|
||||
|
||||
(define (parse-command-line line)
|
||||
(if (eof-object? line) ; Netscape does this
|
||||
(values "QUIT" "")
|
||||
(let* ((line (trim-spaces line))
|
||||
(split-position (string-index line #\space)))
|
||||
(if split-position
|
||||
(values (upcase-string (substring line 0 split-position))
|
||||
(trim-spaces (substring line
|
||||
(+ 1 split-position)
|
||||
(string-length line))))
|
||||
(values (upcase-string line) "")))))
|
||||
|
||||
; Path names
|
||||
|
||||
; This removes all internal ..'s from a path.
|
||||
; NORMALIZE-PATH returns #f if PATH points to a parent directory.
|
||||
|
||||
(define (normalize-path path)
|
||||
(let loop ((components (split-file-name (simplify-file-name path)))
|
||||
(reverse-result '()))
|
||||
(cond
|
||||
((null? components)
|
||||
(path-list->file-name (reverse reverse-result)))
|
||||
((null? (cdr components))
|
||||
(if (string=? ".." (car components))
|
||||
#f
|
||||
(path-list->file-name
|
||||
(reverse (cons (car components) reverse-result)))))
|
||||
((string=? ".." (cadr components))
|
||||
(loop (cddr components) reverse-result))
|
||||
(else
|
||||
(loop (cdr components) (cons (car components) reverse-result))))))
|
||||
|
||||
(define (file-name-rooted? file-name)
|
||||
(and (not (string=? "" file-name))
|
||||
(char=? #\/ (string-ref file-name 0))))
|
||||
|
||||
(define (file-name-sans-rooted file-name)
|
||||
(substring file-name 1 (string-length file-name)))
|
||||
|
||||
(define split-arguments
|
||||
(infix-splitter " +"))
|
||||
|
||||
; Reply handling
|
||||
|
||||
; Replies must be synchronous with requests and actions. Therefore,
|
||||
; they are queued on generation via REGISTER-REPLY!. The messages are
|
||||
; printed via WRITE-REPLIES. For the nature of the replies, see RFC
|
||||
; 959.
|
||||
|
||||
|
||||
(define (write-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-session-reverse-replies '()))
|
||||
|
||||
(define (write-final-reply line)
|
||||
(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 (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-session-reverse-replies
|
||||
(cons message (session-reverse-replies)))
|
||||
(set-session-reply-code code))
|
||||
|
||||
; Version
|
||||
|
||||
(define *ftpd-version* "$Revision: 1.1.2.1 $")
|
||||
|
||||
(define (copy-port->port-binary input-port output-port)
|
||||
(let ((buffer (make-string *window-size*)))
|
||||
(let loop ()
|
||||
(cond
|
||||
((read-string! buffer input-port)
|
||||
=> (lambda (length)
|
||||
(write-string buffer output-port 0 length)
|
||||
(loop))))))
|
||||
(force-output output-port))
|
||||
|
||||
(define (copy-port->port-ascii input-port output-port)
|
||||
(let loop ()
|
||||
(let ((line (read-line input-port 'concat)))
|
||||
(if (not (eof-object? line))
|
||||
(let ((length (string-length line)))
|
||||
(cond
|
||||
((zero? length)
|
||||
'fick-dich-ins-knie)
|
||||
((char=? #\newline (string-ref line (- length 1)))
|
||||
(write-string line output-port 0 (- length 1))
|
||||
(write-crlf output-port))
|
||||
(else
|
||||
(write-string line output-port)))
|
||||
(loop)))))
|
||||
(force-output output-port))
|
||||
|
||||
(define (copy-ascii-port->port input-port output-port)
|
||||
(let loop ()
|
||||
(let* ((line (read-crlf-line input-port
|
||||
#f
|
||||
90000 ; timeout
|
||||
500)) ; max interval
|
||||
(length (string-length line)))
|
||||
(if (not (eof-object? line))
|
||||
(begin
|
||||
(write-string line output-port 0 length)
|
||||
(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))))
|
||||
|
||||
; Stuff from Big Scheme
|
||||
; We can't open BIG-SCHEME because we use virgin SIGNALS. Sigh.
|
||||
|
||||
(define any? (structure-ref big-scheme any?))
|
||||
(define partition-list (structure-ref big-scheme partition-list))
|
|
@ -0,0 +1,92 @@
|
|||
;;; Handle fatal errors in a sensible way. -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
;;; (with-fatal-error-handler* handler thunk)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
|
||||
;;; and that condition is an error condition (or a subtype of error), then
|
||||
;;; HANDLER gets a chance to handle it.
|
||||
;;; The HANDLER proc is applied to two values:
|
||||
;;; (HANDLER condition decline)
|
||||
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
|
||||
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
|
||||
;;; handle the error by throwing to DECLINE, a nullary continuation.
|
||||
;;;
|
||||
;;; Why is it called with-FATAL-error-handler*? Because returning to the
|
||||
;;; guy that signalled the error is not an option.
|
||||
;;;
|
||||
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
|
||||
;;; error handler *itself* raises an error? This could potentially give
|
||||
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
|
||||
;;; the original condition-signaller's context, so you'd search back for a
|
||||
;;; handler, and find yourself again. For example, here is an infinite loop:
|
||||
;;;
|
||||
;;; (with-handler (lambda (condition more)
|
||||
;;; (display "Loop!")
|
||||
;;; (error "ouch")) ; Get back, Loretta.
|
||||
;;; (lambda () (error "start me up")))
|
||||
;;;
|
||||
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
|
||||
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
|
||||
;;; if it signals a condition, we'll start the search from there. That's the
|
||||
;;; point of continuation K. When the original thunk completes successfully,
|
||||
;;; we dodge the K hackery by using ACCEPT to make a normal return.
|
||||
|
||||
(define (with-fatal-error-handler* handler thunk)
|
||||
(call-with-current-continuation
|
||||
(lambda (accept)
|
||||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-handler (lambda (condition more)
|
||||
(if (error? condition)
|
||||
(call-with-current-continuation
|
||||
(lambda (decline)
|
||||
(k (lambda () (handler condition decline))))))
|
||||
(more)) ; Keep looking for a handler.
|
||||
(lambda () (call-with-values thunk accept)))))))))
|
||||
|
||||
(define-syntax with-fatal-error-handler
|
||||
(syntax-rules ()
|
||||
((with-fatal-error-handler handler body ...)
|
||||
(with-fatal-error-handler* handler
|
||||
(lambda () body ...)))))
|
||||
|
||||
;This one ran HANDLER in the signaller's condition-handler context.
|
||||
;It was therefore susceptible to infinite loops if you didn't code
|
||||
;your handler's carefully.
|
||||
;
|
||||
;(define (with-fatal-error-handler* handler thunk)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (accept)
|
||||
; (with-handler (lambda (condition more)
|
||||
; (if (error? condition)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (decline)
|
||||
; (accept (handler condition decline)))))
|
||||
; (more)) ; Keep looking for a handler.
|
||||
; thunk))))
|
||||
|
||||
;;; (%error-handler-cond kont eh-clauses cond-clauses)
|
||||
;;; Transform error-handler clauses into COND clauses by wrapping continuation
|
||||
;;; KONT around the body of each e-h clause, so that if it fires, the result
|
||||
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
|
||||
;;; continuation.
|
||||
|
||||
;(define-syntax %error-handler-cond
|
||||
; (syntax-rules (=> else)
|
||||
;
|
||||
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
|
||||
; (%error-handler-cond kont
|
||||
; (clause ...)
|
||||
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
|
||||
;
|
||||
; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
|
||||
; (%error-handler-cond kont
|
||||
; (clause ...)
|
||||
; ((test (kont (begin body ...))) ans ...)))
|
||||
;
|
||||
; ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
|
||||
; (cond (else body ...) ans-clause ...))
|
||||
;
|
||||
; ((%error-handler-cond kont () (ans-clause ...))
|
||||
; (cond ans-clause ...))))
|
|
@ -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))))
|
||||
|
||||
|
|
|
@ -26,11 +26,9 @@
|
|||
(define (access-controller . controls)
|
||||
(lambda (info)
|
||||
(let loop ((controls controls))
|
||||
(if (null? controls)
|
||||
#f
|
||||
(cond
|
||||
(((car controls) info) => identity)
|
||||
(else (loop (cdr controls))))))))
|
||||
(and (pair? controls)
|
||||
(or ((car controls) info)
|
||||
(loop (cdr controls)))))))
|
||||
|
||||
(define (access-controlled-handler control ph)
|
||||
(lambda (path req)
|
||||
|
|
|
@ -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"))
|
||||
))
|
||||
|
|
|
@ -6,10 +6,6 @@
|
|||
;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
|
||||
;;; CONDITION-STUFF.
|
||||
;;;
|
||||
;;; You can find out more about the Scheme 48 condition system by consulting
|
||||
;;; s48-error.txt, where I scribbled some notes as I was browsing the source
|
||||
;;; code when I wrote this file.
|
||||
|
||||
;;; ,open conditions signals handle
|
||||
|
||||
;;; HTTP error condition
|
||||
|
@ -39,93 +35,3 @@
|
|||
(define (fatal-syntax-error msg . irritants)
|
||||
(apply signal 'fatal-syntax-error msg irritants))
|
||||
|
||||
|
||||
;;; (with-fatal-error-handler* handler thunk)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
|
||||
;;; and that condition is an error condition (or a subtype of error), then
|
||||
;;; HANDLER gets a chance to handle it.
|
||||
;;; The HANDLER proc is applied to two values:
|
||||
;;; (HANDLER condition decline)
|
||||
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
|
||||
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
|
||||
;;; handle the error by throwing to DECLINE, a nullary continuation.
|
||||
;;;
|
||||
;;; Why is it called with-FATAL-error-handler*? Because returning to the
|
||||
;;; guy that signalled the error is not an option.
|
||||
;;;
|
||||
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
|
||||
;;; error handler *itself* raises an error? This could potentially give
|
||||
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
|
||||
;;; the original condition-signaller's context, so you'd search back for a
|
||||
;;; handler, and find yourself again. For example, here is an infinite loop:
|
||||
;;;
|
||||
;;; (with-handler (lambda (condition more)
|
||||
;;; (display "Loop!")
|
||||
;;; (error "ouch")) ; Get back, Loretta.
|
||||
;;; (lambda () (error "start me up")))
|
||||
;;;
|
||||
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
|
||||
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
|
||||
;;; if it signals a condition, we'll start the search from there. That's the
|
||||
;;; point of continuation K. When the original thunk completes successfully,
|
||||
;;; we dodge the K hackery by using ACCEPT to make a normal return.
|
||||
|
||||
(define (with-fatal-error-handler* handler thunk)
|
||||
(call-with-current-continuation
|
||||
(lambda (accept)
|
||||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-handler (lambda (condition more)
|
||||
(if (error? condition)
|
||||
(call-with-current-continuation
|
||||
(lambda (decline)
|
||||
(k (lambda () (handler condition decline))))))
|
||||
(more)) ; Keep looking for a handler.
|
||||
(lambda () (call-with-values thunk accept)))))))))
|
||||
|
||||
(define-syntax with-fatal-error-handler
|
||||
(syntax-rules ()
|
||||
((with-fatal-error-handler handler body ...)
|
||||
(with-fatal-error-handler* handler
|
||||
(lambda () body ...)))))
|
||||
|
||||
;This one ran HANDLER in the signaller's condition-handler context.
|
||||
;It was therefore susceptible to infinite loops if you didn't code
|
||||
;your handler's carefully.
|
||||
;
|
||||
;(define (with-fatal-error-handler* handler thunk)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (accept)
|
||||
; (with-handler (lambda (condition more)
|
||||
; (if (error? condition)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (decline)
|
||||
; (accept (handler condition decline)))))
|
||||
; (more)) ; Keep looking for a handler.
|
||||
; thunk))))
|
||||
|
||||
;;; (%error-handler-cond kont eh-clauses cond-clauses)
|
||||
;;; Transform error-handler clauses into COND clauses by wrapping continuation
|
||||
;;; KONT around the body of each e-h clause, so that if it fires, the result
|
||||
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
|
||||
;;; continuation.
|
||||
|
||||
;(define-syntax %error-handler-cond
|
||||
; (syntax-rules (=> else)
|
||||
;
|
||||
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
|
||||
; (%error-handler-cond kont
|
||||
; (clause ...)
|
||||
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
|
||||
;
|
||||
; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
|
||||
; (%error-handler-cond kont
|
||||
; (clause ...)
|
||||
; ((test (kont (begin body ...))) ans ...)))
|
||||
;
|
||||
; ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
|
||||
; (cond (else body ...) ans-clause ...))
|
||||
;
|
||||
; ((%error-handler-cond kont () (ans-clause ...))
|
||||
; (cond ans-clause ...))))
|
||||
|
|
|
@ -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 ""))))))
|
||||
|
@ -499,7 +499,9 @@
|
|||
(define (file-extension->content-type fname)
|
||||
(switch string-ci=? (file-name-extension fname)
|
||||
((".html") "text/html")
|
||||
((".txt") "text/plain")
|
||||
((".gif") "image/gif")
|
||||
((".png") "image/png")
|
||||
((".jpg" ".jpeg") "image/jpeg")
|
||||
((".tiff" ".tif") "image/tif")
|
||||
((".rtf") "text/rtf")
|
||||
|
@ -511,7 +513,8 @@
|
|||
((".zip") "application/zip")
|
||||
((".tar") "application/tar")
|
||||
((".ps") "application/postscript")
|
||||
(else #f)))
|
||||
((".pdf") "application/pdf")
|
||||
(else "application/octet-stream")))
|
||||
|
||||
(define (file-extension->content-encoding fname)
|
||||
(cond
|
||||
|
|
|
@ -0,0 +1,290 @@
|
|||
; ls clone in scsh
|
||||
|
||||
; Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
||||
; Copyright (c) 1998 Michael Sperber.
|
||||
|
||||
; This currently does a whole bunch of stats on every file in some
|
||||
; cases. In a decent OS implementation, this stuff is cached, so
|
||||
; there isn't any problem, at least not in theory :-)
|
||||
|
||||
; FLAGS is a list of symbols from:
|
||||
;
|
||||
; all - include stuff starting with "."
|
||||
; recursive - guess what
|
||||
; long - output interesting information per file
|
||||
; directory - display only the information for the directory named
|
||||
; flag - flag files as per their types
|
||||
; columns - sorts output vertically in a multicolumn format
|
||||
|
||||
(define (ls flags paths . maybe-port)
|
||||
(let* ((port (optional maybe-port (current-output-port)))
|
||||
(paths (if (null? paths)
|
||||
(list (cwd))
|
||||
paths))
|
||||
(only-one? (null? (cdr paths))))
|
||||
(call-with-values
|
||||
(lambda () (parse-flags flags))
|
||||
(lambda (all? recursive? long? directory? flag? columns?)
|
||||
(real-ls paths
|
||||
(if only-one? #f "")
|
||||
all? recursive? long? directory? flag? columns?
|
||||
port)))))
|
||||
|
||||
(define (parse-flags flags)
|
||||
(let ((all? (memq 'all flags))
|
||||
(recursive? (memq 'recursive flags))
|
||||
(long? (memq 'long flags))
|
||||
(directory? (memq 'directory flags))
|
||||
(flag? (memq 'flag flags))
|
||||
(columns? (memq 'columns flags)))
|
||||
(values all? recursive? long? directory? flag? columns?)))
|
||||
|
||||
(define (real-ls paths prefix
|
||||
all? recursive? long? directory? flag? columns?
|
||||
port)
|
||||
(let ((first #t))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(if first
|
||||
(set! first #f)
|
||||
(newline port))
|
||||
(if prefix
|
||||
(format port "~A~A:~%" prefix path))
|
||||
(ls-path path all? recursive? long? directory? flag? columns? port))
|
||||
paths)))
|
||||
|
||||
(define (ls-path path all? recursive? long? directory? flag? columns? port)
|
||||
(cond
|
||||
((and (file-directory? path #f)
|
||||
(not directory?))
|
||||
(ls-directory path all? recursive? long? directory? flag? columns? port))
|
||||
(else
|
||||
(ls-file path long? flag? port))))
|
||||
|
||||
(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
|
||||
(let* ((directory (file-name-as-directory directory))
|
||||
(substantial-directory (string-append directory "."))
|
||||
(files (directory-files substantial-directory all?)))
|
||||
(with-cwd*
|
||||
substantial-directory
|
||||
(lambda ()
|
||||
(if (and (not long?)
|
||||
columns?)
|
||||
(ls-files-columns files flag? port)
|
||||
(ls-files-column files long? flag? port))
|
||||
|
||||
(if recursive?
|
||||
(let ((directories
|
||||
(map (lambda (file-name)
|
||||
(string-append directory file-name))
|
||||
(filter (lambda (file)
|
||||
(file-directory? file #f))
|
||||
files))))
|
||||
(if (not (null? directories))
|
||||
(begin
|
||||
(newline port)
|
||||
(real-ls directories directory
|
||||
all? recursive? long? directory? flag? columns?
|
||||
port)))))))))
|
||||
|
||||
(define *width* 79)
|
||||
|
||||
(define (ls-files-columns files flag? port)
|
||||
(let* ((max-file-name-width
|
||||
(if (null? files)
|
||||
0
|
||||
(apply max (map string-length files))))
|
||||
(max-file-name-width
|
||||
(if flag?
|
||||
(+ 1 max-file-name-width)
|
||||
max-file-name-width))
|
||||
|
||||
(column-width (+ 2 max-file-name-width))
|
||||
|
||||
(columns (quotient *width*
|
||||
column-width))
|
||||
(columns (if (zero? columns)
|
||||
1
|
||||
columns))
|
||||
|
||||
(number-of-files (length files))
|
||||
(rows (quotient (+ number-of-files (- columns 1))
|
||||
columns))
|
||||
|
||||
(tails
|
||||
(do ((column 0 (+ 1 column))
|
||||
(tails (make-vector columns)))
|
||||
((= column columns)
|
||||
tails)
|
||||
(vector-set! tails column
|
||||
(list-tail-or-null files (* rows column))))))
|
||||
|
||||
(do ((row 0 (+ 1 row)))
|
||||
((= row rows))
|
||||
(do ((column 0 (+ 1 column)))
|
||||
((= column columns))
|
||||
(let ((tail (vector-ref tails column)))
|
||||
(if (not (null? tail))
|
||||
(let ((width (display-file (car tail) flag? port)))
|
||||
(display-spaces (- column-width width) port)
|
||||
(vector-set! tails column (cdr tail))))))
|
||||
(newline port))))
|
||||