sync with WSI branch

This commit is contained in:
mainzelm 2000-10-01 14:59:56 +00:00
parent 303c3343b3
commit c4036bb8d0
17 changed files with 1597 additions and 166 deletions

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)

View File

@ -99,7 +99,7 @@
(nph? (string-suffix? "-nph" prog)) ; PROG end in "-nph" ?
(search (http-url:search (request:url req))) ; Compute the
(argv (if (and search (not (index search #\=))) ; argv list.
(argv (if (and search (not (string-index search #\=))) ; argv list.
(split-and-decode-search-spec search)
'()))
@ -125,7 +125,7 @@
(define (split-and-decode-search-spec s)
(let recur ((i 0))
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
(? ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
(recur (+ j 1)))))
(else (list (unescape-uri s i (string-length s)))))))
@ -182,7 +182,7 @@
("SCRIPT_NAME" . ,script-name)
("REMOTE_HOST" . ,(host-info:name (host-info raddr)))
("REMOTE_ADDR" . ,(internet-address->dotted-string rhost))
("REMOTE_ADDR" . ,(internet-host-address->dotted-string rhost))
;; ("AUTH_TYPE" . xx) ; Random authentication
;; ("REMOTE_USER" . xx) ; features I don't understand.
@ -265,15 +265,3 @@
(close-input-port script-port))))
;;; This proc and its inverse should be in a general IP module.
(define (internet-address->dotted-string num32)
(let* ((num24 (arithmetic-shift num32 -8))
(num16 (arithmetic-shift num24 -8))
(num08 (arithmetic-shift num16 -8))
(byte0 (bitwise-and #b11111111 num08))
(byte1 (bitwise-and #b11111111 num16))
(byte2 (bitwise-and #b11111111 num24))
(byte3 (bitwise-and #b11111111 num32)))
(string-append (number->string byte0) "." (number->string byte1) "."
(number->string byte2) "." (number->string byte3))))

View File

@ -36,4 +36,18 @@
(write-string "\r\n" port)
(force-output port))
(define (read-crlf-line-timeout . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f)
(timeout 8000)
(max-interval 500))
(let loop ((waited 0) (interval 100))
(cond ((> waited timeout)
'timeout)
((char-ready? fd/port)
(read-crlf-line fd/port retain-crlf?))
(else (sleep interval)
(loop (+ waited interval) (min (* interval 2)
max-interval)))))))

829
ftpd.scm Normal file
View File

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

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

View File

@ -120,6 +120,7 @@
(apply emit-tag out tag attrs)
(call-with-values thunk
(lambda results
(newline out)
(emit-close-tag out tag)
(apply values results))))

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)

View File

@ -50,11 +50,13 @@
(define *http-log?* #t)
(define *http-log-port* (error-output-port))
(define *http-log-port* (open-output-file "/tmp/bla"))
(define (http-log fmt . args)
(? (*http-log?*
(apply format *http-log-port* fmt args)
(force-output *http-log-port*))))
(if *http-log?*
(begin
(apply format *http-log-port* fmt args)
(force-output *http-log-port*)
)))
;;; (httpd path-handler [port server-root-dir])
@ -74,21 +76,18 @@
;; closes the connection, we won't lose when we try to close the
;; socket by trying to flush the output buffer.
(lambda (sock addr) ; Called once for every connection.
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
(fork (lambda () ; Kill this line to bag forking.
(let* ((i (dup->inport (socket:inport sock) 0))
(o (dup->outport (socket:outport sock) 1)))
(set-port-buffering i bufpol/none) ; Should propagate. ecch.
(with-current-input-port i ; bind the
(with-current-output-port o ; stdio ports, &
(process-toplevel-request path-handler sock))) ; do it.
(close-input-port i) ; Really only necessary
(close-output-port o)))) ; for non-forking variant.
(reap-zombies) ; Clean up: reap dead children,
(close-socket sock)) ; and close socket.
(set-port-buffering (socket:outport sock) 'bufpol/none) ; No buffering
(spawn (lambda () ; Kill this line to bag forking.
; Should propagate. ecch.
(with-current-input-port
(socket:inport sock) ; bind the
(with-current-output-port
(socket:outport sock) ; stdio ports, &
(set-port-buffering (current-input-port) 'bufpol/none)
(process-toplevel-request path-handler sock)
(close-socket sock))) ; do it.
)))
port))))
;;; Top-level http request processor
@ -141,6 +140,15 @@
headers ; An rfc822 header alist (see rfc822.scm).
socket) ; The socket connected to the client.
(define-record-discloser type/request
(lambda (req)
(list 'request
(request:method req)
(request:uri req)
(request:url req)
(request:version req)
(request:headers req)
(request:socket req))))
;;; A http protocol version is an integer pair: (major . minor).
(define (version< v1 v2)
@ -249,9 +257,9 @@
(define (string->words s)
(let recur ((start 0))
(? ((char-set-index s non-whitespace start) =>
(cond ((char-set-index s non-whitespace start) =>
(lambda (start)
(? ((char-set-index s char-set:whitespace start) =>
(cond ((char-set-index s char-set:whitespace start) =>
(lambda (end)
(cons (substring s start end)
(recur end))))
@ -351,6 +359,8 @@
(apply really-send-http-error-reply reply-code req args))))
(define (really-send-http-error-reply reply-code req . args)
(http-log "sending error-reply ~a ~%" reply-code)
(let* ((message (if (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '()))
@ -367,7 +377,7 @@
(reply-code->text reply-code)
new-protocol?)))
(do-msg (lambda () (? (message (display message out) (newline out))))))
(do-msg (lambda () (cond (message (display message out) (newline out))))))
(if new-protocol? (begin-http-header out reply-code))
@ -423,7 +433,7 @@
(if message (format out "<P>~%~a~%" message))))
((http-reply/internal-error)
(format (error-output-port) "ERROR: ~A~%" message)
(format (current-error-port) "ERROR: ~A~%" message)
(when html-ok?
(generic-title)
(format out "The server encountered an internal error or
@ -444,10 +454,12 @@ the requested method (~A).~%"
(else (if html-ok? (generic-title))))
(? (html-ok?
(cond (html-ok?
;; Output extra stuff and close the <body> tag.
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" out)))
; (force-output out) ;;; TODO check this
; (flush-all-ports)
(force-output out)
; (if bkp? (breakpoint "http error"))
))

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

View File

@ -55,7 +55,7 @@
(define (alist-path-dispatcher handler-alist default-handler)
(lambda (path req)
(? ((and (pair? path) (assoc (car path) handler-alist)) =>
(cond ((and (pair? path) (assoc (car path) handler-alist)) =>
(lambda (entry) ((cdr entry) (cdr path) req)))
(else (default-handler path req)))))
@ -175,11 +175,11 @@
(http-error http-reply/bad-request req
"Indexed search not provided for this URL.")
(? ((dotdot-check root file-path) =>
(lambda (fname) (file-serve fname file-path req)))
(else
(http-error http-reply/bad-request req
"URL contains unresolvable ..'s.")))))
(cond ((dotdot-check root file-path) =>
(lambda (fname) (file-serve fname file-path req)))
(else
(http-error http-reply/bad-request req
"URL contains unresolvable ..'s.")))))
;; Just (file-info fname) with error handling.
@ -309,14 +309,14 @@
=> (lambda (open-match)
(cond
((regexp-exec title-close-tag-regexp stuff
(match:end open-match))
(match:end open-match 0))
=> (lambda (close-match)
(string-cut (substring stuff
(match:end open-match)
(match:start close-match))
(match:end open-match 0)
(match:start close-match 0))
n)))
(else (string-cut (substring stuff
(match:end open-match)
(match:end open-match 0)
(string-length stuff))
n)))))
(else ""))))))
@ -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))))