From c4036bb8d0f65de31f421612e6111977e07282bd Mon Sep 17 00:00:00 2001 From: mainzelm Date: Sun, 1 Oct 2000 14:59:56 +0000 Subject: [PATCH] sync with WSI branch --- Makefile | 42 ++ cgi-server.scm | 18 +- crlf-io.scm | 16 +- ftpd.scm | 829 +++++++++++++++++++++++++++++++++++++++ handle-fatal-error.scm | 92 +++++ htmlout.scm | 1 + httpd-access-control.scm | 8 +- httpd-core.scm | 58 +-- httpd-error.scm | 94 ----- httpd-handlers.scm | 25 +- ls.scm | 290 ++++++++++++++ modules.scm | 70 +++- parse-forms.scm | 16 +- rfc822.scm | 2 +- rman-gateway.scm | 167 ++++++++ stringhax.scm | 26 ++ uri.scm | 9 +- 17 files changed, 1597 insertions(+), 166 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/cgi-server.scm b/cgi-server.scm index 12e3074..4c678a9 100644 --- a/cgi-server.scm +++ b/cgi-server.scm @@ -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)))) diff --git a/crlf-io.scm b/crlf-io.scm index 19294b4..f2d4445 100644 --- a/crlf-io.scm +++ b/crlf-io.scm @@ -36,4 +36,18 @@ (write-string "\r\n" port) (force-output port)) - +(define (read-crlf-line-timeout . args) + (let-optionals args ((fd/port (current-input-port)) + (retain-crlf? #f) + (timeout 8000) + (max-interval 500)) + (let loop ((waited 0) (interval 100)) + (cond ((> waited timeout) + 'timeout) + ((char-ready? fd/port) + (read-crlf-line fd/port retain-crlf?)) + (else (sleep interval) + (loop (+ waited interval) (min (* interval 2) + max-interval))))))) + + diff --git a/ftpd.scm b/ftpd.scm new file mode 100644 index 0000000..c529f3e --- /dev/null +++ b/ftpd.scm @@ -0,0 +1,829 @@ +; 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-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)) 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/htmlout.scm b/htmlout.scm index 523baa2..71d10d2 100644 --- a/htmlout.scm +++ b/htmlout.scm @@ -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)))) 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-core.scm b/httpd-core.scm index effb1a5..613c549 100644 --- a/httpd-core.scm +++ b/httpd-core.scm @@ -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 "

~%~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 tag. (for-each (lambda (x) (format out "
~s~%" x)) extras) (write-string "\n" out))) + ; (force-output out) ;;; TODO check this + ; (flush-all-ports) (force-output out) ; (if bkp? (breakpoint "http error")) )) 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..84ad026 100644 --- a/httpd-handlers.scm +++ b/httpd-handlers.scm @@ -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 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..287f29d 100644 --- a/modules.scm +++ b/modules.scm @@ -34,11 +34,13 @@ (define-structure crlf-io (export read-crlf-line + read-crlf-line-timeout write-crlf) (open ascii ; ascii->char scsh ; read-line write-string force-output receiving ; MV return (RECEIVE and VALUES) let-opt ; let-optionals + threads ; sleep scheme) (files crlf-io)) @@ -64,6 +66,7 @@ (open receiving ; MV return (RECEIVE and VALUES) condhax ; ? for COND scsh-utilities ; index + string-lib let-opt ; let-optionals strings ; lowercase-string uppercase-string crlf-io ; read-crlf-line @@ -82,7 +85,8 @@ string-reduce skip-whitespace string-prefix? - string-suffix?) + string-suffix? + trim-spaces) (open char-set-package let-opt scheme) (files stringhax)) @@ -95,6 +99,7 @@ uri-path-list->path simplify-uri-path) (open scsh-utilities + string-lib let-opt receiving condhax @@ -141,6 +146,7 @@ (open defrec-package receiving condhax + string-lib char-set-package uri-package scsh-utilities @@ -152,12 +158,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 @@ -224,7 +232,8 @@ set-my-fqdn! set-my-port!) - (open scsh + (open threads + scsh receiving let-opt crlf-io @@ -234,10 +243,12 @@ strings char-set-package defrec-package + define-record-types handle conditions ; condition-stuff defenum-package httpd-error + handle-fatal-error uri-package url-package formats @@ -247,7 +258,7 @@ ;;; For parsing submissions from HTML forms. (define-structure parse-html-forms (export parse-html-form-query unescape-uri+) - (open scsh scsh-utilities let-opt + (open scsh scsh-utilities let-opt string-lib receiving uri-package strings condhax scheme) (files parse-forms)) @@ -266,6 +277,7 @@ cgi-handler initialise-request-invariant-cgi-env) (open strings + string-lib rfc822 crlf-io ; WRITE-CRLF uri-package @@ -360,6 +372,7 @@ find-info-file info-gateway-error) (open big-scheme + string-lib conditions signals handle switch-syntax condhax @@ -372,3 +385,48 @@ 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 + threads + fluids + string-lib + defrec-package + crlf-io strings ls) + (access big-scheme) + (files ftpd)) diff --git a/parse-forms.scm b/parse-forms.scm index 6eabc46..46f99c8 100644 --- a/parse-forms.scm +++ b/parse-forms.scm @@ -4,7 +4,7 @@ ;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html ;;; Imports and non-R4RS'isms -;;; index (scsh) +;;; string-index (string srfi) ;;; let-optionals (let-opt package) ;;; receive (Multiple-value return) ;;; unescape-uri @@ -45,12 +45,14 @@ (define (parse-html-form-query q) (let ((qlen (string-length q))) (let recur ((i 0)) - (? ((index q #\= i) => - (lambda (j) - (let ((k (or (index q #\& j) qlen))) - (cons (cons (unescape-uri+ q i j) - (unescape-uri+ q (+ j 1) k)) - (recur (+ k 1)))))) + (cond + ((>= i qlen) '()) + ((string-index q #\= i) => + (lambda (j) + (let ((k (or (string-index q #\& j) qlen))) + (cons (cons (unescape-uri+ q i j) + (unescape-uri+ q (+ j 1) k)) + (recur (+ k 1)))))) (else '()))))) ; BOGUS STRING -- Issue a warning. diff --git a/rfc822.scm b/rfc822.scm index 7334759..d5c629e 100644 --- a/rfc822.scm +++ b/rfc822.scm @@ -105,7 +105,7 @@ (values #f #f) ; Blank line or EOF terminates header text. - (? ((index line1 #\:) => ; Find the colon and + (? ((string-index line1 #\:) => ; Find the colon and (lambda (colon) ; split out field name. (let ((name (string->symbol-pref (substring line1 0 colon)))) ;; Read in continuation lines. 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))))) diff --git a/uri.scm b/uri.scm index 0abb714..136c1cb 100644 --- a/uri.scm +++ b/uri.scm @@ -50,7 +50,11 @@ ;;; Returns four values: scheme, path, search, frag-id. ;;; Each value is either #f or a string. -(define uri-reserved (string->char-set "=;/#?: ")) + +;;; MG: I think including = here will break up things, since it may be +;;; part of the search string, preventing the ? to be found (+ and & +;;; are excluded anyway). +(define uri-reserved (string->char-set ";/#?: ")) (define (parse-uri s) (let* ((slen (string-length s)) @@ -68,7 +72,6 @@ (ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult)) (path-end (or ques sharp slen))) - (values (and colon (substring s 0 colon)) (split-uri-path s path-start path-end) (and ques (substring s (+ ques 1) (or sharp slen))) @@ -231,7 +234,7 @@ (define (split-uri-path uri start end) ; Split at /'s (infix grammar). (let split ((i start)) ; "" -> ("") (? ((>= i end) '("")) - ((index uri #\/ i) => + ((string-index uri #\/ i) => (lambda (slash) (cons (substring uri i slash) (split (+ slash 1)))))