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

Sync with the WSI repository

This commit is contained in:
mainzelm 2000-09-26 15:32:01 +00:00
parent 01310403c1
commit 5862701455
10 changed files with 1454 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
Makefile Normal file
View File

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

779
ftpd.scm Normal file
View File

@ -0,0 +1,779 @@
; 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 (ftpd . maybe-port)
(let ((port (optional maybe-port 21)))
(bind-listen-accept-loop
protocol-family/internet
(lambda (socket address)
(set-ftp-socket-options! socket)
(fork
(lambda ()
(handle-connection (socket:inport socket)
(socket:outport socket))
(reap-zombies)
(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))
; 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)
(escape 'fick-dich-ins-knie))
(lambda ()
(set! *control-input-port* input-port)
(set! *control-output-port* output-port)
(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 *control-input-port*)))
;; (format #t "Command line: ~A~%" command-line)
(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 *logged-in?* #f)
(define *authenticated?* #f)
(define *anonymous?* #f)
(define *root-directory* #f)
(define *current-directory* "")
(define (handle-user name)
(cond
(*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 "ftp")))
(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* "")
(register-reply! 230 "Anonymous user logged in.")))
(define (handle-pass password)
(cond
((not *logged-in?*)
(register-reply! 530 "You have not logged in yet."))
(*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 *root-directory* current-directory))
(lambda () ; I hate gratuitous syntax
(set! *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\"."
*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 *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 *to-be-renamed* #f)
(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! *to-be-renamed* full-path))))
(define (handle-rnto path)
(ensure-authenticated-login)
(if (not *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*
(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 *to-be-renamed* full-path)
(register-reply! 250 "File renamed.")
(set! *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 *type* 'ascii)
(define (handle-type arg)
(cond
((string-ci=? "A" arg)
(set! *type* 'ascii))
((string-ci=? "I" arg)
(set! *type* 'image))
((string-ci=? "L8" arg)
(set! *type* 'image))
(else
(signal-error! 504
(format #f "Unknown TYPE: ~A." arg))))
(register-reply! 200
(format #f "TYPE is now ~A."
(case *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 (+ (arithmetic-shift a1 24)
(arithmetic-shift a2 16)
(arithmetic-shift a3 8)
a4)
(+ (arithmetic-shift p1 8)
p2)))
components))))
(else
(signal-error! 500
"Syntax error in argument to PORT."))))
(define *data-socket* #f)
(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! *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)
(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! *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)
(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))))
(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 *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 *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 *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 *type*
((image)
(copy-port->port-binary
file-port
(socket:outport *data-socket*)))
((ascii)
(copy-port->port-ascii
file-port
(socket:outport *data-socket*)))))))))))))
(define (handle-stor path)
(ensure-authenticated-login)
(let ((full-path (string-append *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 *type*
((image)
(copy-port->port-binary
(socket:inport *data-socket*)
file-port))
((ascii)
(copy-ascii-port->port
(socket:inport *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*)
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 *logged-in?*)
(not *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 *data-socket*) (not *passive-socket*))
(signal-error! 425 "No data connection."))
(if *passive-socket*
(call-with-values
(lambda () (accept-connection *passive-socket*))
(lambda (socket socket-address)
(set! *data-socket* socket))))
(register-reply! 150 "Opening data connection.")
(write-replies)
(set-socket-option *data-socket* level/socket
socket/send-buffer *window-size*)
(set-socket-option *data-socket* level/socket
socket/receive-buffer *window-size*))
(define (maybe-close-data-connection)
(if (or *data-socket* *passive-socket*)
(close-data-connection)))
(define (close-data-connection)
(if *data-socket*
(close-socket *data-socket*))
(if *passive-socket*
(close-socket *passive-socket*))
(register-reply! 226 "Closing data connection.")
(set! *data-socket* #f)
(set! *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 (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 *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 (null? (cdr messages))
(write-final-reply (car messages))
(begin
(write-nonfinal-reply (car messages))
(loop (cdr messages))))))
(set! *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*))
(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*))
(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))
; Version
(define *ftpd-version* "$Revision: 1.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))
(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))

92
handle-fatal-error.scm Normal file
View File

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

8
httpd-access-control.scm
View File

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

94
httpd-error.scm
View File

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

5
httpd-handlers.scm
View File

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

290
ls.scm Normal file
View File

@ -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))))
(define (list-tail-or-null list index)
(let loop ((list list) (index index))
(cond
((null? list) list)
((zero? index) list)
(else (loop (cdr list) (- index 1))))))
(define (ls-files-column files long? flag? port)
(for-each
(lambda (file)
(ls-file file long? flag? port))
files))
(define (ls-file file-name long? flag? port)
(if long?
(ls-file-long file-name flag? port)
(ls-file-short file-name flag? port)))
(define (ls-file-short file-name flag? port)
(display-file file-name flag? port)
(newline port))
(define (ls-file-long file-name flag? port)
(let ((info (file-info file-name #f)))
(display-permissions info port)
(display-decimal-justified (file-info:nlinks info) 4 port)
(write-char #\space port)
(let ((user-name (user-info:name (user-info (file-info:uid info)))))
(display-padded user-name 9 port))
(let ((group-name (group-info:name (group-info (file-info:gid info)))))
(display-padded group-name 9 port))
(display-decimal-justified (file-info:size info) 7 port)
(write-char #\space port)
(display-time (file-info:mtime info) port)
(write-char #\space port)
(display-file file-name flag? port)
(if (file-symlink? file-name)
(begin
(display " -> " port)
(display (read-symlink file-name) port)))
(newline port)))
(define *year-seconds* (* 365 24 60 60))
(define (display-time the-time port)
(let ((time-difference (abs (- (time) the-time)))
(date (date the-time 0)))
(if (< time-difference *year-seconds*)
(display (format-date "~b ~d ~H:~M" date) port)
(display (format-date "~b ~d ~Y " date) port))))
(define (display-file file-name flag? port)
(display file-name port)
(if (maybe-display-flag file-name flag? port)
(+ 1 (string-length file-name))
(string-length file-name)))
(define (maybe-display-flag file-name flag? port)
(if (not (and flag?
(not (file-regular? file-name))))
#f
(begin
(cond
((file-directory? file-name)
(write-char #\/ port))
((file-symlink? file-name)
(write-char #\@ port))
((file-executable? file-name)
(write-char #\* port))
((file-socket? file-name)
(write-char #\= port))
((file-fifo? file-name)
(write-char #\| port)))
#t)))
(define (display-permissions info port)
(case (file-info:type info)
((directory)
(write-char #\d port))
((symlink)
(write-char #\l port))
(else
(write-char #\- port)))
(let ((mode (file-info:mode info))
(bit 8))
(for-each
(lambda (id)
(if (not (zero? (bitwise-and (arithmetic-shift 1 bit)
mode)))
(write-char id port)
(write-char #\- port))
(set! bit (- bit 1)))
'(#\r #\w #\x #\r #\w #\x #\r #\w #\x))))
(define (display-decimal-justified number width port)
(display-justified (number->string number) width port))
(define (display-justified string width port)
(let ((length (string-length string)))
(if (< length width)
(display-spaces (- width length) port))
(display string port)))
(define (display-padded string width port)
(let ((length (string-length string)))
(display string port)
(if (< length width)
(display-spaces (- width length) port))))
(define (display-spaces number port)
(do ((i 0 (+ 1 i)))
((= i number))
(write-char #\space port)))
;; Convert Unix-style arguments to flags suitable for LS.
(define (arguments->ls-flags args)
(let loop ((args args) (flags '()))
(if (null? args)
flags
(cond
((argument->ls-flags (car args))
=> (lambda (new-flags)
(loop (cdr args) (append new-flags flags))))
(else #f)))))
(define (argument->ls-flags arg)
(let ((arg (if (symbol? arg)
(symbol->string arg)
arg)))
(if (or (string=? "" arg)
(not (char=? #\- (string-ref arg 0))))
#f
(let loop ((chars (cdr (string->list arg))) (flags '()))
(cond
((null? chars)
flags)
((char->flag (car chars))
=> (lambda (flag)
(loop (cdr chars) (cons flag flags))))
(else #f))))))
(define (char->flag char)
(case char
((#\a) 'all)
((#\R) 'recursive)
((#\l) 'long)
((#\d) 'directory)
((#\F) 'flag)
((#\C) 'columns)
(else #f)))
(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))))

55
modules.scm
View File

@ -82,7 +82,8 @@
string-reduce
skip-whitespace
string-prefix?
string-suffix?)
string-suffix?
trim-spaces)
(open char-set-package let-opt scheme)
(files stringhax))
@ -152,12 +153,14 @@
(define-structure httpd-error (export http-error?
http-error
fatal-syntax-error?
fatal-syntax-error
with-fatal-error-handler*
(with-fatal-error-handler :syntax))
fatal-syntax-error)
(open conditions signals handle scheme)
(files httpd-error))
(define-structure handle-fatal-error (export with-fatal-error-handler*
(with-fatal-error-handler :syntax))
(open scheme conditions handle)
(files handle-fatal-error))
(define-structure httpd-core (export server/version
server/protocol
@ -238,6 +241,7 @@
conditions ; condition-stuff
defenum-package
httpd-error
handle-fatal-error
uri-package
url-package
formats
@ -321,6 +325,7 @@
htmlout-package
conditions ; CONDITION-STUFF
url-package ; HTTP-URL record type
handle-fatal-error
scheme)
(files httpd-handlers))
@ -369,6 +374,48 @@
httpd-error
url-package
uri-package
handle-fatal-error
scsh
scheme)
(files info-gateway))
(define-structure rman-gateway (export rman-handler
man
parse-man-entry
cat-man-page
find-man-file
file->man-directory
cat-n-decode
nroff-n-decode)
(open httpd-core
httpd-error
conditions
url-package
uri-package
htmlout-package
httpd-basic-handlers
switch-syntax
condhax
handle-fatal-error
scsh
let-opt
scheme)
(files rman-gateway))
(define-structure ls (export ls
arguments->ls-flags)
(open scheme
big-scheme bitwise
scsh)
(files ls))
(define-structure ftpd (export ftpd
ftpd-inetd)
(open scheme
conditions handle signals
structure-refs
handle-fatal-error
scsh
crlf-io strings ls)
(access big-scheme)
(files ftpd))

167
rman-gateway.scm Normal file
View File

@ -0,0 +1,167 @@
;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
;;; Copyright (c) 1996 by Mike Sperber.
;;; This uses RosettaMan and is currently based on version 2.5a6
;;; (RosettaMan is based at
;;; ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
(define rman/rman '(rman -fHTML))
(define rman/man '(man))
(define rman/nroff '(nroff -man))
(define rman/gzcat '(zcat))
(define rman/zcat '(zcat))
(define (rman-handler finder referencer address . maybe-man)
(let ((parse-man-url
(cond
((procedure? finder) finder)
((list? finder)
(lambda (url)
(values finder
(unescape-uri (http-url:search url))
'())))
(else
(let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
(lambda (url)
(values man-path
(unescape-uri (http-url:search url))
'()))))))
(reference-template
(cond
((procedure? referencer) referencer)
((string? referencer) (lambda (entry section) referencer))
(else (lambda (entry section) "man?%s(%s)"))))
(man (:optional maybe-man man)))
(lambda (path req)
(switch string=? (request:method req)
(("GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(else
(decline))))
(if (not (v0.9-request? req))
(begin
(begin-http-header #t http-reply/ok)
(write-string "Content-type: text/html\r\n")
(write-string "\r\n")))
(receive (man-path entry and-then) (parse-man-url (request:url req))
(emit-man-page entry man man-path and-then reference-template))
(with-tag #t address ()
(display address))))
(else (http-error http-reply/method-not-allowed req))))))
(define (cat-man-page key section)
(let ((title (if section
(format #f "~a(~a) manual page" key section)
(format #f "~a manual page" key))))
(emit-title #t title)
(emit-header #t 1 title)
(newline)
(with-tag #t body ()
(with-tag #t pre ()
(copy-inport->outport (current-input-port)
(current-output-port))))))
(define (emit-man-page entry man man-path and-then reference-template)
(receive (key section) (parse-man-entry entry)
(let ((status
(cond
((procedure? and-then)
(run (| (begin (man section key man-path))
(begin (and-then key section)))))
(else
(run (| (begin (man section key man-path))
(,@rman/rman ,@and-then
-r ,(reference-template entry section))))))))
(if (not (zero? status))
(http-error http-reply/internal-error #f
"internal error emitting man page")))))
(define parse-man-entry
(let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))
(lambda (s)
(cond
((regexp-exec entry-regexp s)
=> (lambda (match)
(values (match:substring match 1)
(match:substring match 2))))
(else (values s #f))))))
(define (man section key man-path)
(cond
((procedure? man-path) (man-path))
((find-man-file key section "cat" man-path) => cat-n-decode)
((find-man-file key section "man" man-path) => nroff-n-decode)
(else
(if (not (zero?
(with-env (("MANPATH" . ,(join-strings man-path ":")))
(run (,@rman/man ,@(if section `(,section) '()) ,key)
(< /dev/null)
(> 2 /dev/null)))))
(http-error http-reply/not-found #f "man page not found")))))
(define man-default-sections
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
(define (find-man-file name section cat-man man-path . maybe-sections)
(define (section-dir section)
(lambda (dir)
(file-name-as-directory
(string-append (file-name-as-directory dir)
cat-man
section))))
(let* ((prefix (if section
(string-append name "." section)
(string-append name ".")))
(pattern (string-append (glob-quote prefix) "*"))
(sections (:optional maybe-sections man-default-sections))
(path (if section
(map (section-dir section) man-path)
(apply append
(map (lambda (dir)
(map (lambda (section)
((section-dir section) dir))
sections))
man-path)))))
(let loop ((path path))
(and (not (null? path))
(let ((matches (glob (string-append (car path) pattern))))
(if (not (null? matches))
(car matches)
(loop (cdr path))))))))
(define (file->man-directory file)
(path-list->file-name
(reverse
(cdr
(reverse
(split-file-name
(file-name-directory file)))))))
(define (cat-n-decode file)
(let ((ext (file-name-extension file)))
(cond
((string=? ".gz" ext) (run (,@rman/gzcat ,file)))
((string=? ".Z" ext) (run (,@rman/zcat ,file)))
(else (call-with-input-file
file
(lambda (port)
(copy-inport->outport port (current-output-port))))))))
(define (nroff-n-decode file)
(if (not (zero? (run (| (begin (cat-n-decode file))
(begin
(with-cwd (file->man-directory file)
(exec-epf (,@rman/nroff))))))))
(http-error http-reply/not-found #f "man page not found")))

26
stringhax.scm
View File

@ -1,5 +1,6 @@
;;; Random string-hacking procs -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; Copyright (c) 1997 by Mike Sperber
(define (string-map f s)
(let* ((slen (string-length s))
@ -61,3 +62,28 @@
(define skip-whitespace
(let ((non-whitespace (char-set-invert char-set:whitespace)))
(lambda (s) (char-set-index s non-whitespace))))
; Why is this so complicated?
(define (trim-spaces string)
(if (string=? "" string)
string
(let* ((length (string-length string))
(start
(if (not (char=? #\space (string-ref string 0)))
0
(do ((index 0 (+ 1 index)))
((or (= index length)
(not (char=? #\space (string-ref string index))))
index))))
(end
(if (not (char=? #\space (string-ref string (- length 1))))
length
(do ((index (- length 1) (- index 1)))
((or (= index 0)
(not (char=? #\space (string-ref string index))))
(+ 1 index))))))
(if (and (= 0 start)
(= length end))
string
(substring string start end)))))