From 5862701455845abd06b3a9bb1aceaa7a91ee1da8 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Tue, 26 Sep 2000 15:32:01 +0000 Subject: [PATCH] Sync with the WSI repository --- Makefile | 42 +++ ftpd.scm | 779 +++++++++++++++++++++++++++++++++++++++ handle-fatal-error.scm | 92 +++++ httpd-access-control.scm | 8 +- httpd-error.scm | 94 ----- httpd-handlers.scm | 5 +- ls.scm | 290 +++++++++++++++ modules.scm | 55 ++- rman-gateway.scm | 167 +++++++++ stringhax.scm | 26 ++ 10 files changed, 1454 insertions(+), 104 deletions(-) create mode 100644 Makefile create mode 100644 ftpd.scm create mode 100644 handle-fatal-error.scm create mode 100644 ls.scm create mode 100644 rman-gateway.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..9a4e28d --- /dev/null +++ b/Makefile @@ -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) diff --git a/ftpd.scm b/ftpd.scm new file mode 100644 index 0000000..b3e7e22 --- /dev/null +++ b/ftpd.scm @@ -0,0 +1,779 @@ +; RFC 959 ftp daemon + +; Mike Sperber +; 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)) diff --git a/handle-fatal-error.scm b/handle-fatal-error.scm new file mode 100644 index 0000000..10dee02 --- /dev/null +++ b/handle-fatal-error.scm @@ -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 ...)))) diff --git a/httpd-access-control.scm b/httpd-access-control.scm index be61e4a..b9689d6 100644 --- a/httpd-access-control.scm +++ b/httpd-access-control.scm @@ -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) diff --git a/httpd-error.scm b/httpd-error.scm index 754dc14..41a6675 100644 --- a/httpd-error.scm +++ b/httpd-error.scm @@ -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 ...)))) diff --git a/httpd-handlers.scm b/httpd-handlers.scm index 06d6fce..e5e54e7 100644 --- a/httpd-handlers.scm +++ b/httpd-handlers.scm @@ -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 diff --git a/ls.scm b/ls.scm new file mode 100644 index 0000000..ee78418 --- /dev/null +++ b/ls.scm @@ -0,0 +1,290 @@ +; ls clone in scsh + +; Mike Sperber +; 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)))) diff --git a/modules.scm b/modules.scm index d9783b8..f10690a 100644 --- a/modules.scm +++ b/modules.scm @@ -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)) diff --git a/rman-gateway.scm b/rman-gateway.scm new file mode 100644 index 0000000..8e1f842 --- /dev/null +++ b/rman-gateway.scm @@ -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"))) diff --git a/stringhax.scm b/stringhax.scm index 4739651..ba4b78e 100644 --- a/stringhax.scm +++ b/stringhax.scm @@ -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)))))