From d1438eb4a8716e5f5f992d44ce35a9e0e556b617 Mon Sep 17 00:00:00 2001 From: sperber Date: Mon, 26 Aug 2002 09:46:11 +0000 Subject: [PATCH] Rework the API of path handlers: Path handlers must now return a response object similar to the response objects of the PLT web server, encapsulating headers, mime type, status code, and so on. A response object in turn can contain an encoding of a body. The only presently supported body type is a procedure which just prints the body. Other changes: - split file-dir-handler.scm out from handlers.scm - moved the ICON-NAME constructor parameters for file handlers to the options - removed input/output port redirections and work with paths explicitly --- scheme/httpd/core.scm | 343 +++++++++++--------- scheme/httpd/file-dir-handler.scm | 500 +++++++++++++++++++++++++++++ scheme/httpd/handlers.scm | 512 ------------------------------ scheme/httpd/options.scm | 22 +- scheme/httpd/response.scm | 18 ++ scheme/httpd/text-generation.scm | 11 +- scheme/packages.scm | 75 +++-- 7 files changed, 773 insertions(+), 708 deletions(-) create mode 100644 scheme/httpd/file-dir-handler.scm create mode 100644 scheme/httpd/response.scm diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 0792eb4..a9b6dde 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -74,12 +74,8 @@ (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering (fork-thread (lambda () - (with-current-input-port - (socket:inport sock) - (with-current-output-port - (socket:outport sock) - (set-port-buffering (current-input-port) bufpol/none) - (process-toplevel-request sock host-address options))) + (set-port-buffering (current-input-port) bufpol/none) + (process-toplevel-request sock host-address options) (if *http-syslog?* (http-syslog (syslog-level debug) "<~a>~a [closing]~%" (pid) @@ -120,43 +116,58 @@ ;; PROCESS-TOPLEVEL-REQUEST. ;; ;; We *oughta* map non-http-errors into replies anyway. - (with-fatal-error-handler (lambda (c decline) ; No call to decline - (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%" - (pid) - (format-internet-host-address host-address) - c) - (if (http-error? c) ; -- we handle all. - (apply (lambda (reply-code req . args) - (apply send-http-error-reply - reply-code req options - args)) - (condition-stuff c)) - (with-fatal-error-handler - (lambda (c decline) - (http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%" - (pid) - (format-internet-host-address host-address) - c)) - (shutdown-socket sock shutdown/sends+receives) - (http-syslog (syslog-level info) "<~a>~a [shut down]~%" - (pid) - (format-internet-host-address host-address))))) - - (let ((req (with-fatal-error-handler ; Map syntax errors - (lambda (c decline) ; to http errors. - (if (fatal-syntax-error? c) - (apply http-error http-reply/bad-request - #f ; No request yet. - "Request parsing error -- report to client maintainer." - (condition-stuff c)) - (decline))) ; Actual work: - (parse-http-request sock options))) ; (1) Parse request. - (handler - (httpd-options-path-handler options))) - (handler (http-url:path (request:url req)) req) ; (2) Deal with it. - (http-log req http-reply/ok)))) - - + (with-fatal-error-handler* + (lambda (c decline) + (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%" + (pid) + (format-internet-host-address host-address) + c) + (with-fatal-error-handler* + (lambda (c decline) + (http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%" + (pid) + (format-internet-host-address host-address) + c)) + (lambda () + (shutdown-socket sock shutdown/sends+receives) + (http-syslog (syslog-level info) "<~a>~a [shut down]~%" + (pid) + (format-internet-host-address host-address)) + (decline)))) + (lambda () + (call-with-values + (lambda () + (with-fatal-error-handler* + (lambda (c decline) + (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%" + (pid) + (format-internet-host-address host-address) + c) + (cond + ((http-error? c) + (apply (lambda (reply-code req . args) + (values req + (apply make-http-error-response + reply-code req + args))) + (condition-stuff c))) + ((fatal-syntax-error? c) + (values #f + (apply make-http-error-response http-reply/bad-request + #f ; No request yet. + "Request parsing error -- report to client maintainer." + (condition-stuff c)))) + (else + (decline)))) + (lambda () + (let* ((req (parse-http-request sock options)) + (response ((httpd-options-path-handler options) + (http-url:path (request:url req)) + req))) + (values req response))))) + (lambda (req response) + (send-http-response response (socket:outport sock) options) + (http-log req http-reply/ok)))))) ;;;; HTTP request parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -172,8 +183,7 @@ ;;; the Web, the protocols are redundant, underconstrained, and ill-specified. (define (parse-http-request sock options) - (let ((line (read-crlf-line))) -; (display line (current-error-port)) (newline (current-error-port)) + (let ((line (read-crlf-line (socket:inport sock)))) ;; Blat out some logging info. (if *http-syslog?* (call-with-values @@ -198,7 +208,7 @@ (uri-string (cadr elts)) (url (parse-http-servers-url-fragment uri-string sock options)) (headers (if (equal? version '(0 . 9)) '() - (read-rfc822-headers)))) + (read-rfc822-headers (socket:inport sock))))) (make-request meth uri-string url version headers sock)))))) @@ -264,146 +274,167 @@ (else (list (substring s start (string-length s))))))) (else '())))) +(define (send-http-response response port options) -;;; (send-http-error-reply reply-code req options [message . extras]) + (display server/protocol port) + (write-char #\space port) + (display (response-code response) port) + (write-char #\space port) + (display (response-message response) port) + (write-crlf port) + + (send-http-headers + (list (cons 'server server/version) + (cons 'content-type (response-mime response)) + (cons 'date (time->http-date-string (response-seconds response)))) + port) + (send-http-headers (response-extras response) port) + + (write-crlf port) + + (display-http-body (response-body response) port options)) + +(define (send-http-headers headers port) + (for-each (lambda (pair) + (display (car pair) port) + (display ": " port) + (display (cdr pair) port) + (write-crlf port)) + headers)) + +;;; (make-http-error-response reply-code req [message . extras]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Take an http-error condition, and format it into a reply to the client. ;;; ;;; As a special case, request REQ is allowed to be #f, meaning we haven't ;;; even had a chance to parse and construct the request. This is only used -;;; for 400 BAD-REQUEST error report, and we make minimal assumptions in this -;;; case (0.9 protocol for the reply, for example). I might be better off -;;; writing a special-case procedure for that case... +;;; for 400 BAD-REQUEST error report. -;;; SEND-HTTP-ERROR-REPLY is called from error handlers, so to avoid +;;; MAKE-HTTP-ERROR-RESPONSE is called from error handlers, so to avoid ;;; infinite looping, if an error occurs while it is running, we just ;;; silently return. (We no longer need to do this; I have changed ;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll ;;; leave it in to play it safe.) -(define (send-http-error-reply reply-code req options . args) - (ignore-errors (lambda () ; Ignore errors -- see note above. - (apply really-send-http-error-reply reply-code req options args)))) +(define (make-http-error-response reply-code req . args) + (ignore-errors + (lambda () ; Ignore errors -- see note above. + (apply really-make-http-error-response reply-code req args)))) -(define (really-send-http-error-reply reply-code req options . args) +(define (really-make-http-error-response reply-code req . args) (http-log req reply-code) - (let* ((message (if (pair? args) (car args))) + (let* ((message (and (pair? args) (car args))) (extras (if (pair? args) (cdr args) '())) - (new-protocol? (and req (not (v0.9-request? req)))) ; 1.0 or better? + (generic-title (lambda (port) + (title-html port + (reply-code->text reply-code)))) + (close-html (lambda (port) + (for-each (lambda (x) (format port "
~s~%" x)) extras) + (write-string "\n" port))) + + (create-response + (lambda (headers writer-proc) + (make-response reply-code + (reply-code->text reply-code) + (time) + "text/html" + headers + (make-writer-body writer-proc))))) - ;; Is it OK to send back an HTML body explaining things? - (html-ok? (or (not req) - (not (string=? (request:method req) "HEAD")))) - - (out (current-output-port)) - - (generic-title (lambda () - (title-html out - (reply-code->text reply-code) - new-protocol?))) - - (do-msg (lambda () (cond (message (display message out) (newline out)))))) - - (if new-protocol? (begin-http-header out reply-code)) - - ;; Don't output the blank line, as individual clauses might - ;; want to add more headers. - (if html-ok? (write-string "Content-type: text/html\r\n" out)) - - ;; If html-ok?, we must send back some html, with the tag unclosed. (cond + ;; This error reply requires two args: message is the new URI: field, + ;; and the first EXTRA is the older Location: field. + ((or (= reply-code http-reply/moved-temp) + (= reply-code http-reply/moved-perm)) + (create-response + (list (cons 'uri message) + (cons 'location (car extras))) + (lambda (port options) + (title-html port "Document moved") + (format port + "This document has ~A moved to a new location.~%" + (if (= reply-code http-reply/moved-temp) "temporarily" "permanently") + message) + (close-html port)))) - ;; This error reply requires two args: message is the new URI: field, - ;; and the first EXTRA is the older Location: field. - ((or (= reply-code http-reply/moved-temp) - (= reply-code http-reply/moved-perm)) - (if new-protocol? - (begin - (format out "URI: ~A\r~%" message) - (format out "Location: ~A\r~%" (car extras)))) - (if html-ok? - (begin - (title-html out "Document moved" new-protocol?) - (format out - "This document has ~A moved to a new location.~%" - (if (= reply-code http-reply/moved-temp) "temporarily" "permanently") - message)))) + ((= reply-code http-reply/bad-request) + (create-response + '() + (lambda (port options) + (generic-title port) + (write-string "

Client sent a query that this server could not understand.\n" + port) + (if message (format port "
~%Reason: ~A~%" message)) + (close-html port)))) - ((= reply-code http-reply/bad-request) - (if html-ok? - (begin - (generic-title) - (write-string "

Client sent a query that this server could not understand.\n" - out) - (if message (format out "
~%Reason: ~A~%" message))))) + ((= reply-code http-reply/unauthorized) + (create-response + (list (cons 'WWW-Authenticate message)) ; Vas is das? + (lambda (port options) + (title-html port "Authorization Required") + (write-string "

Browser not authentication-capable or\n" port) + (write-string "authentication failed.\n" port) + (if message (format port "~a~%" message)) + (close-html port)))) - ((= reply-code http-reply/unauthorized) - (if new-protocol? - (format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das? - (if html-ok? - (begin - (title-html out "Authorization Required" new-protocol?) - (write-string "

Browser not authentication-capable or\n" out) - (write-string "authentication failed.\n" out) - (if message (format out "~a~%" message))))) - - ((= reply-code http-reply/forbidden) - (if (not html-ok?) - (begin - (title-html out "Request not allowed." new-protocol?) - (format out - "Your client does not have permission to perform a ~A~%" - (request:method req)) - (format out "operation on url ~a.~%" (request:uri req)) - (if message (format out "

~%~a~%" message))))) + ((= reply-code http-reply/forbidden) + (create-response + '() + (lambda (port options) + (title-html port "Request not allowed.") + (format port + "Your client does not have permission to perform a ~A~%" + (request:method req)) + (format port "operation on url ~a.~%" (request:uri req)) + (if message (format port "

~%~a~%" message)) + (close-html port)))) - ((= reply-code http-reply/not-found) - (if html-ok? - (begin - (title-html out "URL not found" new-protocol?) - (write-string - "

The requested URL was not found on this server.\n" - out) - (if message (format out "

~%~a~%" message))))) + ((= reply-code http-reply/not-found) + (create-response + '() + (lambda (port options) + (title-html port "URL not found") + (write-string + "

The requested URL was not found on this server.\n" + port) + (if message (format port "

~%~a~%" message)) + (close-html port)))) - ((= reply-code http-reply/internal-error) - (http-syslog (syslog-level error) "internal-error: ~A" message) - (if html-ok? - (begin - (generic-title) - (format out "The server encountered an internal error or + ((= reply-code http-reply/internal-error) + (http-syslog (syslog-level error) "internal-error: ~A" message) + (create-response + '() + (lambda (port options) + (generic-title port) + (format port "The server encountered an internal error or misconfiguration and was unable to complete your request.

Please inform the server administrator, ~A, of the circumstances leading to the error, and time it occured.~%" - (httpd-options-server-admin options)) - (if message (format out "

~%~a~%" message))))) - - ((= reply-code http-reply/not-implemented) - (if html-ok? - (begin - (generic-title) - (format out "This server does not currently implement + (httpd-options-server-admin options)) + (if message (format port "

~%~a~%" message)) + (close-html port)))) + + ((= reply-code http-reply/not-implemented) + (create-response + '() + (lambda (port options) + (generic-title port) + (format port "This server does not currently implement the requested method (~A).~%" - (request:method req)) - (if message (format out "

~a~%" message))))) + (request:method req)) + (if message (format port "

~a~%" message)) + (close-html port)))) - (else - (http-syslog (syslog-level info) "Skipping unhandled reply code ~A.~%" reply-code) - (if html-ok? (generic-title)))) - - (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")) - )) + (else + (http-syslog (syslog-level info) "Skipping unhandled reply code ~A.~%" reply-code) + (create-response + '() + (lambda (port options) + (generic-title port) + (close-html port))))))) ;;; Return my Internet host name (my fully-qualified domain name). diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm new file mode 100644 index 0000000..877ba1c --- /dev/null +++ b/scheme/httpd/file-dir-handler.scm @@ -0,0 +1,500 @@ +(define server/buffer-size 8192) ; WTF + +;;; (home-dir-handler user-public-dir) -> handler +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Return a path handler that looks things up in a specific directory +;;; in the user's home directory. If ph = (home-dir-handler "public_html") +;;; then ph is a path-handler that serves files out of peoples' public_html +;;; subdirectory. So +;;; (ph '("shivers" "hk.html") req) +;;; will serve the file +;;; ~shivers/public_html/hk.html +;;; The path handler treats the URL path as ( . ), +;;; serving +;;; ~// + +(define (home-dir-handler user-public-dir) + (lambda (path req) + (if (pair? path) + (make-rooted-file-path-response (string-append (http-homedir (car path) req) + "/" + user-public-dir) + (cdr path) + file-serve-response + req) + (make-http-error-response http-reply/bad-request + req + "Path contains no home directory.")))) + +;;; (tilde-home-dir-handler-predicate path) +;;; (tilde-home-dir-handler user-public-dir) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"), +;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the +;;; default handler. + +(define (tilde-home-dir-handler-predicate path) + (lambda (path) + (and (pair? path) ; Is it a ~foo/... + (let ((head (car path))) ; home-directory path? + (and (> (string-length head) 0) + (char=? (string-ref head 0) #\~)))))) + +(define (tilde-home-dir-handler user-public-dir) + (lambda (path req) + (let* ((tilde-home (car path)) ; Yes. + (slen (string-length tilde-home)) + (subdir (string-append + (http-homedir (substring tilde-home 1 slen) req) + "/" + user-public-dir))) + (make-rooted-file-path-response subdir (cdr path) file-serve-response req)))) + + +;;; Make a handler that serves files relative to a particular root +;;; in the file system. You may follow symlinks, but you can't back up +;;; past ROOT with ..'s. + +(define (rooted-file-handler root) + (lambda (path req) + (make-rooted-file-path-response root path file-serve-response req))) + +;;; Dito, but also serve directory indices for directories without +;;; index.html. + +(define (rooted-file-or-directory-handler root) + (lambda (path req) + (make-rooted-file-path-response root path + file-serve-and-dir-response + req))) + + +;;; The null path handler -- handles nothing, sends back an error reply. +;;; Can be useful as the default in table-driven path handlers. + +(define (null-path-handler path req) + (make-http-error-response http-reply/not-found req)) + +;;;; Support procs for the path handlers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Do a request for a file. The file-name is determined by appending the +;;; the FILE-PATH list the string ROOT. E.g., if +;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html") +;;; then we serve file +;;; /usr/shivers/a/b/c/foo.html +;;; Elements of FILE-PATH are *not allowed* to contain .. elements. +;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path +;;; sequences are processed away by the browser when the URI is converted +;;; to an absolute URI before it is sent off to the server.) +;;; It is possible to sneak a .. past this kind of front-end resolving by +;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries +;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction. +;;; So you cannot make the reference back up past ROOT. E.g., this is +;;; not allowed: +;;; FILE-PATH = ("a" "../.." "c" "foo.html") +;;; +;;; Only GET and HEAD ops are provided. +;;; The URL's component must be #f. +;;; The file is served if the server has read or stat(2) access to it, +;;; respectively. If the server is run as root, this might be a problem. +;;; +;;; FILE-SERVE is a procedure which gets passed the file name, the +;;; path, and the HTTP request to serve the file propert after the +;;; security checks. Look in ROOTED-FILE-HANDLER and +;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this. + +(define (make-rooted-file-path-response root file-path file-serve-response req) + (if (http-url:search (request:url req)) + (make-http-error-response http-reply/bad-request req + "Indexed search not provided for this URL.") + (cond ((dotdot-check root file-path) => + (lambda (fname) + (file-serve-response fname file-path req))) + (else + (make-http-error-response http-reply/bad-request req + "URL contains unresolvable ..'s."))))) + + +;; Just (file-info fname) with error handling. + +(define (stat-carefully fname req) + (with-errno-handler + ((errno packet) + ((errno/noent) + (http-error http-reply/not-found req)) + ((errno/acces) + (http-error http-reply/forbidden req))) + (file-info fname #t))) + +;;; A basic file request handler -- ship the dude the file. No fancy path +;;; checking. That has presumably been taken care of. This handler only +;;; takes care of GET and HEAD methods. + +(define (file-serve-or-dir-response fname file-path req directory-serve-response) + (if (file-name-directory? fname) ; Simple index generation. + (directory-serve-response fname file-path req) + + (let ((request-method (request:method req))) + (cond + ((or (string=? request-method "GET") + (string=? request-method "HEAD")) ; Absolutely. + (let ((info (stat-carefully fname req))) + (case (file-info:type info) + + ((regular fifo socket) + (send-file-response fname info req)) + + ((directory) ; Send back a redirection "foo" -> "foo/" + (make-http-error-response + http-reply/moved-perm req + (string-append (request:uri req) "/") + (string-append (http-url->string (request:url req)) + "/"))) + + (else (make-http-error-response http-reply/forbidden req))))) + + (else (make-http-error-response http-reply/method-not-allowed req)))))) + +(define (directory-index-serve-response fname file-path req) + (file-serve-response (string-append fname "index.html") file-path req)) + +(define (file-serve-response fname file-path req) + (file-serve-or-dir-response fname file-path req + directory-index-serve-response)) + +(define (tag->alt tag) + (case tag + ((directory) "[DIR]") + ((text) "[TXT]") + ((doc) "[DOC]") + ((image) "[IMG]") + ((movie) "[MVI]") + ((audio) "[AU ]") + ((archive) "[TAR]") + ((compressed) "[ZIP]") + ((uu) "[UU ]") + ((binhex) "[HQX]") + ((binary) "[BIN]") + (else "[ ]"))) + +;; These icons can, for example, be found in the cern-httpd-3.0 +;; distribution at http://www.w3.org/pub/WWW/Daemon/ + +(define (tag->icon tag) + (case tag + ((directory) "directory.xbm") + ((text) "text.xbm") + ((doc) "doc.xbm") + ((image) "image.xbm") + ((movie) "movie.xbm") + ((audio) "sound.xbm") + ((archive) "tar.xbm") + ((compressed) "compressed.xbm") + ((uu) "uu.xbm") + ((binhex) "binhex.xbm") + ((binary) "binary.xbm") + ((blank) "blank.xbm") + ((back) "back.xbm") + (else "unknown.xbm"))) + +(define (file-extension->tag fname) + (let ((ext (file-name-extension fname))) + (cond + ((string-ci=? ext ".txt") 'text) + ((or (string-ci=? ext ".doc") + (string-ci=? ext ".html") + (string-ci=? ext ".rtf") + (string-ci=? ext ".tex")) 'doc) + ((or (string-ci=? ext ".gif") + (string-ci=? ext ".jpg") + (string-ci=? ext ".jpeg") + (string-ci=? ext ".tiff") + (string-ci=? ext ".tif")) 'image) + ((or (string-ci=? ext ".mpeg") + (string-ci=? ext ".mpg")) 'movie) + ((or (string-ci=? ext ".au") + (string-ci=? ext ".snd") + (string-ci=? ext ".wav")) 'audio) + ((or (string-ci=? ext ".tar") + (string-ci=? ext ".zip") + (string-ci=? ext ".zoo")) 'archive) + ((or (string-ci=? ext ".gz") + (string-ci=? ext ".Z") + (string-ci=? ext ".z")) 'compressed) + ((string-ci=? ext ".uu") 'uu) + ((string-ci=? ext ".hqx") 'binhex) + (else 'binary)))) + +(define (file-tag fname type) + (case type + ((regular fifo socket) (file-extension->tag fname)) + ((directory) 'directory) + (else 'unknown))) + +(define (time->directory-index-date-string time) + (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0))) + +(define (read-max-lines fname max) + (call-with-input-file + fname + (lambda (port) + (let loop ((r "") (i max)) + (if (zero? i) + r + (let ((line (read-line port))) + (if (eof-object? line) + r + (loop (string-append r " " line) (- i 1))))))))) + +(define (string-cut s n) + (if (>= (string-length s) n) + (substring s 0 n) + s)) + +(define html-file-header + (let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>")) + (title-close-tag-regexp (make-regexp ""))) + (lambda (fname n) + (let ((stuff (read-max-lines fname 10))) + (cond + ((regexp-exec title-tag-regexp stuff) + => (lambda (open-match) + (cond + ((regexp-exec title-close-tag-regexp stuff + (match:end open-match 0)) + => (lambda (close-match) + (string-cut (substring stuff + (match:end open-match 0) + (match:start close-match 0)) + n))) + (else (string-cut (substring stuff + (match:end open-match 0) + (string-length stuff)) + n))))) + (else "")))))) + +(define (file-documentation fname n) + (cond + ((file-extension->content-type fname) + => (lambda (content-type) + (if (and (string=? content-type "text/html" ) + (file-readable? fname)) + (html-file-header fname n) + ""))) + (else ""))) + +(define (directory-index req dir icon-name port) + + (define (pad-file-name file) + (write-string (make-string (max (- 21 (string-length file)) + 1) + #\space) + port)) + + (define (emit-file-name file) + (let ((l (string-length file))) + (if (<= l 20) + (emit-text file port) + (emit-text (substring file 0 20) port)))) + + (define (index-entry file) + (let* ((fname (directory-as-file-name (string-append dir file))) + (info (file-info fname #t)) + (type (file-info:type info)) + (size (file-info:size info)) + (tag (file-tag file type))) + (emit-tag port 'img + (cons 'src (icon-name tag)) + (cons 'alt (tag->alt tag))) + (with-tag port a ((href file)) + (emit-file-name file)) + (pad-file-name file) + (emit-text (time->directory-index-date-string (file-info:mtime info)) port) + (if size + (let* ((size-string + (string-append (number->string (quotient size 1024)) + "K")) + (size-string + (if (<= (string-length size-string) 7) + size-string + (string-append (number->string (quotient size (* 1024 1024))) + "M"))) + (size-string + (if (<= (string-length size-string) 8) + (string-append + (make-string (- 8 (string-length size-string)) #\space) + size-string) + size-string))) + (write-string size-string port)) + (write-string (make-string 8 #\space) port)) + (write-char #\space port) + (emit-text (file-documentation fname 24) port) + (write-crlf port))) + + (let ((files (directory-files dir))) + (for-each index-entry files) + (length files))) + +(define (directory-serve-response fname file-path req) + (let ((request-method (request:method req))) + (cond + ((or (string=? request-method "GET") + (string=? request-method "HEAD")) + + (if (not (eq? 'directory + (file-info:type (file-info fname #t)))) + (make-http-error-response http-reply/forbidden req) + (make-response + http-reply/ok + (reply-code->text http-reply/ok) + (time) + "text/html" + '() + (make-writer-body + (lambda (port options) + (let* ((icon-option (httpd-options-icon-name options)) + (icon-name + (cond + ((procedure? icon-option) icon-option) + ((string? icon-option) + (lambda (tag) + (string-append icon-option (tag->icon tag)))) + (else tag->icon)))) + (with-tag port html () + (let ((title (string-append "Index of /" + (string-join file-path "/")))) + (with-tag port head () + (emit-title port title)) + (with-tag port body () + (emit-header port 1 title) + (with-tag port pre () + (emit-tag port 'img + (cons 'src (icon-name 'blank)) + (cons 'alt " ")) + (write-string "Name " port) + (write-string "Last modified " port) + (write-string "Size " port) + (write-string "Description" port) + (emit-tag port 'hr) + (emit-tag port 'img + (cons 'src (icon-name 'back)) + (cons 'alt "[UP ]")) + (if (not (null? file-path)) + (begin + (with-tag port a ((href "..")) + (write-string "Parent directory" port)) + (write-crlf port))) + (let ((n-files (directory-index req fname icon-name port))) + (emit-tag port 'hr) + (format port "~d files" n-files)))))))))))) + (else + (make-http-error-response http-reply/method-not-allowed req))))) + +(define (index-or-directory-serve-response fname file-path req) + (let ((index-fname (string-append fname "index.html"))) + (if (file-readable? index-fname) + (file-serve-response index-fname file-path req) + (directory-serve-response fname file-path req)))) + +(define (file-serve-and-dir-response fname file-path req) + (file-serve-or-dir-response fname file-path req + index-or-directory-serve-response)) + +;;; Look up user's home directory, generating an HTTP error reply if you lose. + +(define (http-homedir username req) + (with-fatal-error-handler (lambda (c decline) + (apply http-error http-reply/bad-request req + "Couldn't find user's home directory." + (condition-stuff c))) + + (home-dir username))) + + +(define (send-file-response filename info req) + (if (file-not-readable? filename) ; #### double stats are no good + (make-http-error-response http-reply/not-found req) + (receive (stripped-filename content-encoding) + (file-extension->content-encoding filename) + (make-response http-reply/ok + (reply-code->text http-reply/ok) + (time) + (file-extension->content-type stripped-filename) + (append (if content-encoding + (cons 'content-encoding content-encoding) + '()) + (list + (cons 'last-modified + (time->http-date-string + (file-info:mtime info))) + (cons 'content-length (file-info:size info)))) + (make-writer-body + (lambda (port options) + (call-with-input-file filename + (lambda (in) + (copy-inport->outport in port))))))))) + + +;;; Assemble a filename from ROOT and the elts of PATH-LIST. +;;; If the assembled filename contains a .. subdirectory, return #f, +;;; otw return the filename. + +(define dotdot-check + (let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir. + (lambda (root path-list) + (let ((fname (if (null? path-list) root ; Bogus hack. + (string-append (file-name-as-directory root) + (string-join path-list "/"))))) + (and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir. + fname))))) + +(define (file-extension->content-type fname) + (let ((ext (file-name-extension fname))) + (cond + ((string-ci=? ext ".html") "text/html") + ((string-ci=? ext ".txt") "text/plain") + ((string-ci=? ext ".gif") "image/gif") + ((string-ci=? ext ".png") "image/png") + ((or (string-ci=? ext ".jpg") + (string-ci=? ext ".jpeg")) "image/jpeg") + ((or (string-ci=? ext ".tiff") + (string-ci=? ext ".tif")) "image/tif") + ((string-ci=? ext ".rtf") "text/rtf") + ((or (string-ci=? ext ".mpeg") + (string-ci=? ext ".mpg")) "video/mpeg") + ((or (string-ci=? ext ".au") + (string-ci=? ext ".snd")) "audio/basic") + ((string-ci=? ext ".wav") "audio/x-wav") + ((string-ci=? ext ".dvi") "application/x-dvi") + ((or (string-ci=? ext ".tex") + (string-ci=? ext ".latex")) "application/latex") + ((string-ci=? ext ".zip") "application/zip") + ((string-ci=? ext ".tar") "application/tar") + ((string-ci=? ext ".ps") "application/postscript") + ((string-ci=? ext ".pdf") "application/pdf") + (else "application/octet-stream")))) + +(define (file-extension->content-encoding fname) + (cond + ((let ((ext (file-name-extension fname))) + (cond + ((string-ci=? ext ".Z") "x-compress") + ((string-ci=? ext ".gz") "x-gzip") + (else #f))) + => (lambda (encoding) + (values (file-name-sans-extension fname) encoding))) + (else (values fname #f)))) + +;;; Timeout on network writes? + +(define (copy-inport->outport in out) + (let ((buf (make-string server/buffer-size))) + (let loop () + (cond ((read-string! buf in) => (lambda (nchars) + (write-string buf out 0 nchars) + (loop)))))) + (force-output out)) diff --git a/scheme/httpd/handlers.scm b/scheme/httpd/handlers.scm index 8eb26e6..dac0019 100644 --- a/scheme/httpd/handlers.scm +++ b/scheme/httpd/handlers.scm @@ -33,9 +33,6 @@ (handler (cdr path) req) (default-handler path req)))) -(define server/buffer-size 8192) ; WTF - - ;;; (alist-path-dispatcher handler-alist default-handler) -> handler ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This function creates a table-driven path-handler that dispatches off @@ -57,512 +54,3 @@ default-handler)) default-handler handler-alist)) - -;;; (home-dir-handler user-public-dir) -> handler -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Return a path handler that looks things up in a specific directory -;;; in the user's home directory. If ph = (home-dir-handler "public_html") -;;; then ph is a path-handler that serves files out of peoples' public_html -;;; subdirectory. So -;;; (ph '("shivers" "hk.html") req) -;;; will serve the file -;;; ~shivers/public_html/hk.html -;;; The path handler treats the URL path as ( . ), -;;; serving -;;; ~// - -(define (home-dir-handler user-public-dir) - (lambda (path req) - (if (pair? path) - (serve-rooted-file-path (string-append (http-homedir (car path) req) - "/" - user-public-dir) - (cdr path) - file-serve - req) - (http-error http-reply/bad-request req - "Path contains no home directory.")))) - -;;; (tilde-home-dir-handler-predicate path) -;;; (tilde-home-dir-handler user-public-dir) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"), -;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the -;;; default handler. - -(define (tilde-home-dir-handler-predicate path) - (lambda (path) - (and (pair? path) ; Is it a ~foo/... - (let ((head (car path))) ; home-directory path? - (and (> (string-length head) 0) - (char=? (string-ref head 0) #\~)))))) - -(define (tilde-home-dir-handler user-public-dir) - (lambda (path req) - (let* ((tilde-home (car path)) ; Yes. - (slen (string-length tilde-home)) - (subdir (string-append - (http-homedir (substring tilde-home 1 slen) req) - "/" - user-public-dir))) - (serve-rooted-file-path subdir (cdr path) file-serve req)))) - - -;;; Make a handler that serves files relative to a particular root -;;; in the file system. You may follow symlinks, but you can't back up -;;; past ROOT with ..'s. - -(define (rooted-file-handler root) - (lambda (path req) - (serve-rooted-file-path root path file-serve req))) - -;;; Dito, but also serve directory indices for directories without -;;; index.html. ICON-NAME specifies how to generate the links to -;;; various decorative icons for the listings. It can either be a -;;; procedure which gets passed one of the icon tags in TAG->ICON and -;;; is expected to return a link pointing to the icon. If it is a -;;; string, that is taken as prefix to which the names from TAG->ICON -;;; are appended. - -(define (rooted-file-or-directory-handler root icon-name) - (let ((file-serve-and-dir (file-server-and-dir icon-name))) - (lambda (path req) - (serve-rooted-file-path root path file-serve-and-dir req)))) - - -;;; The null path handler -- handles nothing, sends back an error reply. -;;; Can be useful as the default in table-driven path handlers. - -(define (null-path-handler path req) - (http-error http-reply/not-found req)) - - -;;;; Support procs for the path handlers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; (SERVE-ROOTED-FILE-PATH root file-path req) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Do a request for a file. The file-name is determined by appending the -;;; the FILE-PATH list the string ROOT. E.g., if -;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html") -;;; then we serve file -;;; /usr/shivers/a/b/c/foo.html -;;; Elements of FILE-PATH are *not allowed* to contain .. elements. -;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path -;;; sequences are processed away by the browser when the URI is converted -;;; to an absolute URI before it is sent off to the server.) -;;; It is possible to sneak a .. past this kind of front-end resolving by -;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries -;;; this, SERVE-ROOTED-FILE-PATH will catch it, and abort the transaction. -;;; So you cannot make the reference back up past ROOT. E.g., this is -;;; not allowed: -;;; FILE-PATH = ("a" "../.." "c" "foo.html") -;;; -;;; Only GET and HEAD ops are provided. -;;; The URL's component must be #f. -;;; The file is served if the server has read or stat(2) access to it, -;;; respectively. If the server is run as root, this might be a problem. -;;; -;;; FILE-SERVE is a procedure which gets passed the file name, the -;;; path, and the HTTP request to serve the file propert after the -;;; security checks. Look in ROOTED-FILE-HANDLER and -;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this. - -(define (serve-rooted-file-path root file-path file-serve req) - (if (http-url:search (request:url req)) - (http-error http-reply/bad-request req - "Indexed search not provided for this URL.") - - (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. - -(define (stat-carefully fname req) - (with-errno-handler - ((errno packet) - ((errno/noent) - (http-error http-reply/not-found req)) - ((errno/acces) - (http-error http-reply/forbidden req))) - (file-info fname #t))) - -;;; A basic file request handler -- ship the dude the file. No fancy path -;;; checking. That has presumably been taken care of. This handler only -;;; takes care of GET and HEAD methods. - -(define (file-serve-or-dir fname file-path req directory-serve) - (if (file-name-directory? fname) ; Simple index generation. - (directory-serve fname file-path req) - - (let ((request-method (request:method req))) - (cond - ((or (string=? request-method "GET") - (string=? request-method "HEAD")) ; Absolutely. - (let ((info (stat-carefully fname req))) - (case (file-info:type info) - - ((regular fifo socket) - (send-file fname info req)) - - ((directory) ; Send back a redirection "foo" -> "foo/" - (http-error http-reply/moved-perm req - (string-append (request:uri req) "/") - (string-append (http-url->string (request:url req)) - "/"))) - - (else (http-error http-reply/forbidden req))))) - - (else (http-error http-reply/method-not-allowed req)))))) - -(define (directory-index-serve fname file-path req) - (file-serve (string-append fname "index.html") file-path req)) - -(define (file-serve fname file-path req) - (file-serve-or-dir fname file-path req directory-index-serve)) - -(define (tag->alt tag) - (case tag - ((directory) "[DIR]") - ((text) "[TXT]") - ((doc) "[DOC]") - ((image) "[IMG]") - ((movie) "[MVI]") - ((audio) "[AU ]") - ((archive) "[TAR]") - ((compressed) "[ZIP]") - ((uu) "[UU ]") - ((binhex) "[HQX]") - ((binary) "[BIN]") - (else "[ ]"))) - -;; These icons can, for example, be found in the cern-httpd-3.0 -;; distribution at http://www.w3.org/pub/WWW/Daemon/ - -(define (tag->icon tag) - (case tag - ((directory) "directory.xbm") - ((text) "text.xbm") - ((doc) "doc.xbm") - ((image) "image.xbm") - ((movie) "movie.xbm") - ((audio) "sound.xbm") - ((archive) "tar.xbm") - ((compressed) "compressed.xbm") - ((uu) "uu.xbm") - ((binhex) "binhex.xbm") - ((binary) "binary.xbm") - ((blank) "blank.xbm") - ((back) "back.xbm") - (else "unknown.xbm"))) - -(define (file-extension->tag fname) - (let ((ext (file-name-extension fname))) - (cond - ((string-ci=? ext ".txt") 'text) - ((or (string-ci=? ext ".doc") - (string-ci=? ext ".html") - (string-ci=? ext ".rtf") - (string-ci=? ext ".tex")) 'doc) - ((or (string-ci=? ext ".gif") - (string-ci=? ext ".jpg") - (string-ci=? ext ".jpeg") - (string-ci=? ext ".tiff") - (string-ci=? ext ".tif")) 'image) - ((or (string-ci=? ext ".mpeg") - (string-ci=? ext ".mpg")) 'movie) - ((or (string-ci=? ext ".au") - (string-ci=? ext ".snd") - (string-ci=? ext ".wav")) 'audio) - ((or (string-ci=? ext ".tar") - (string-ci=? ext ".zip") - (string-ci=? ext ".zoo")) 'archive) - ((or (string-ci=? ext ".gz") - (string-ci=? ext ".Z") - (string-ci=? ext ".z")) 'compressed) - ((string-ci=? ext ".uu") 'uu) - ((string-ci=? ext ".hqx") 'binhex) - (else 'binary)))) - -(define (file-tag fname type) - (case type - ((regular fifo socket) (file-extension->tag fname)) - ((directory) 'directory) - (else 'unknown))) - -(define (time->directory-index-date-string time) - (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0))) - -(define (read-max-lines fname max) - (call-with-input-file - fname - (lambda (port) - (let loop ((r "") (i max)) - (if (zero? i) - r - (let ((line (read-line port))) - (if (eof-object? line) - r - (loop (string-append r " " line) (- i 1))))))))) - -(define (string-cut s n) - (if (>= (string-length s) n) - (substring s 0 n) - s)) - -(define html-file-header - (let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>")) - (title-close-tag-regexp (make-regexp ""))) - (lambda (fname n) - (let ((stuff (read-max-lines fname 10))) - (cond - ((regexp-exec title-tag-regexp stuff) - => (lambda (open-match) - (cond - ((regexp-exec title-close-tag-regexp stuff - (match:end open-match 0)) - => (lambda (close-match) - (string-cut (substring stuff - (match:end open-match 0) - (match:start close-match 0)) - n))) - (else (string-cut (substring stuff - (match:end open-match 0) - (string-length stuff)) - n))))) - (else "")))))) - -(define (file-documentation fname n) - (cond - ((file-extension->content-type fname) - => (lambda (content-type) - (if (and (string=? content-type "text/html" ) - (file-readable? fname)) - (html-file-header fname n) - ""))) - (else ""))) - -(define (directory-index req dir icon-name) - - (define (pad-file-name file) - (write-string (make-string (- 21 (string-length file)) - #\space))) - - (define (emit-file-name file) - (let ((l (string-length file))) - (if (<= l 20) - (emit-text file) - (emit-text (substring file 0 20))))) - - (define (index-entry file) - (let* ((fname (directory-as-file-name (string-append dir file))) - (info (stat-carefully fname req)) - (type (file-info:type info)) - (size (file-info:size info)) - (tag (file-tag file type))) - (emit-tag #t 'img - (cons 'src (icon-name tag)) - (cons 'alt (tag->alt tag))) - (with-tag #t a ((href file)) - (emit-file-name file)) - (pad-file-name file) - (emit-text (time->directory-index-date-string (file-info:mtime info))) - (if size - (let* ((size-string - (string-append (number->string (quotient size 1024)) - "K")) - (size-string - (if (<= (string-length size-string) 7) - size-string - (string-append (number->string (quotient size (* 1024 1024))) - "M"))) - (size-string - (if (<= (string-length size-string) 8) - (string-append - (make-string (- 8 (string-length size-string)) #\space) - size-string) - size-string))) - (write-string size-string)) - (write-string (make-string 8 #\space))) - (write-char #\space) - (emit-text (file-documentation fname 24)) - (newline))) - - (let ((files (with-errno-handler - ((errno packet) - ((errno/acces) - (http-error http-reply/forbidden req))) - (directory-files dir)))) - (for-each index-entry files) - (length files))) - -(define (directory-server icon-name) - (let ((icon-name - (cond - ((procedure? icon-name) icon-name) - ((string? icon-name) - (lambda (tag) - (string-append icon-name (tag->icon tag)))) - (else tag->icon)))) - (lambda (fname file-path req) - (let ((request-method (request:method req))) - (cond - ((or (string=? request-method "GET") - (string=? request-method "HEAD")) - - (if (not (eq? 'directory - (file-info:type (stat-carefully fname req)))) - (http-error http-reply/forbidden req)) - - (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"))) - - (with-tag #t html () - (let ((title (string-append "Index of /" - (string-join file-path "/")))) - (with-tag #t head () - (emit-title #t title)) - (with-tag #t body () - (emit-header #t 1 title) - (with-tag #t pre () - (emit-tag #t 'img - (cons 'src (icon-name 'blank)) - (cons 'alt " ")) - (write-string "Name ") - (write-string "Last modified ") - (write-string "Size ") - (write-string "Description") - (emit-tag #t 'hr) - (emit-tag #t 'img - (cons 'src (icon-name 'back)) - (cons 'alt "[UP ]")) - (if (not (null? file-path)) - (begin - (with-tag #t a ((href "..")) - (write-string "Parent directory")) - (newline))) - (let ((n-files (directory-index req fname icon-name))) - (emit-tag #t 'hr) - (format #t "~d files" n-files))))))) - (else (http-error http-reply/method-not-allowed req))))))) - -(define (index-or-directory-server icon-name) - (let ((directory-serve (directory-server icon-name))) - (lambda (fname file-path req) - (let ((index-fname (string-append fname "index.html"))) - - (if (file-readable? index-fname) - (file-serve index-fname file-path req) - (directory-serve fname file-path req)))))) - -(define (file-server-and-dir icon-name) - (let ((index-or-directory-serve (index-or-directory-server icon-name))) - (lambda (fname file-path req) - (file-serve-or-dir fname file-path req index-or-directory-serve)))) - -;;; Look up user's home directory, generating an HTTP error reply if you lose. - -(define (http-homedir username req) - (with-fatal-error-handler (lambda (c decline) - (apply http-error http-reply/bad-request req - "Couldn't find user's home directory." - (condition-stuff c))) - - (home-dir username))) - - -(define (send-file filename info req) - (with-errno-handler ((errno packet) - ((errno/acces) - (http-error http-reply/forbidden req)) - ((errno/noent) - (http-error http-reply/not-found req))) - (call-with-input-file filename - (lambda (in) - (let ((out (current-output-port))) - (if (not (v0.9-request? req)) - (begin - (begin-http-header out http-reply/ok) - (receive (filename content-encoding) - (file-extension->content-encoding filename) - (if content-encoding - (format out "Content-encoding: ~A\r~%" - content-encoding)) - (cond ((file-extension->content-type filename) => - (lambda (ct) - (format out "Content-type: ~A\r~%" ct))))) - (format out "Last-modified: ~A\r~%" - (time->http-date-string (file-info:mtime info))) - (format out "Content-length: ~D\r~%" (file-info:size info)) - (write-string "\r\n" out))) - (copy-inport->outport in out)))))) - - -;;; Assemble a filename from ROOT and the elts of PATH-LIST. -;;; If the assembled filename contains a .. subdirectory, return #f, -;;; otw return the filename. - -(define dotdot-check - (let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir. - (lambda (root path-list) - (let ((fname (if (null? path-list) root ; Bogus hack. - (string-append (file-name-as-directory root) - (string-join path-list "/"))))) - (and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir. - fname))))) - - -(define (file-extension->content-type fname) - (let ((ext (file-name-extension fname))) - (cond - ((string-ci=? ext ".html") "text/html") - ((string-ci=? ext ".txt") "text/plain") - ((string-ci=? ext ".gif") "image/gif") - ((string-ci=? ext ".png") "image/png") - ((or (string-ci=? ext ".jpg") - (string-ci=? ext ".jpeg")) "image/jpeg") - ((or (string-ci=? ext ".tiff") - (string-ci=? ext ".tif")) "image/tif") - ((string-ci=? ext ".rtf") "text/rtf") - ((or (string-ci=? ext ".mpeg") - (string-ci=? ext ".mpg")) "video/mpeg") - ((or (string-ci=? ext ".au") - (string-ci=? ext ".snd")) "audio/basic") - ((string-ci=? ext ".wav") "audio/x-wav") - ((string-ci=? ext ".dvi") "application/x-dvi") - ((or (string-ci=? ext ".tex") - (string-ci=? ext ".latex")) "application/latex") - ((string-ci=? ext ".zip") "application/zip") - ((string-ci=? ext ".tar") "application/tar") - ((string-ci=? ext ".ps") "application/postscript") - ((string-ci=? ext ".pdf") "application/pdf") - (else "application/octet-stream")))) - -(define (file-extension->content-encoding fname) - (cond - ((let ((ext (file-name-extension fname))) - (cond - ((string-ci=? ext ".Z") "x-compress") - ((string-ci=? ext ".gz") "x-gzip") - (else #f))) - => (lambda (encoding) - (values (file-name-sans-extension fname) encoding))) - (else (values fname #f)))) - -;;; Timeout on network writes? - -(define (copy-inport->outport in out) - (let ((buf (make-string server/buffer-size))) - (let loop () - (cond ((read-string! buf in) => (lambda (nchars) - (write-string buf out 0 nchars) - (loop)))))) - (force-output out)) diff --git a/scheme/httpd/options.scm b/scheme/httpd/options.scm index 4914bfe..5d3f5ea 100644 --- a/scheme/httpd/options.scm +++ b/scheme/httpd/options.scm @@ -7,6 +7,7 @@ (define-record-type httpd-options :httpd-options (really-make-httpd-options port root-directory + icon-name fqdn reported-port path-handler @@ -20,6 +21,14 @@ set-httpd-options-port!) (root-directory httpd-options-root-directory set-httpd-options-root-directory!) + ;; ICON-NAME specifies how to generate the links to + ;; various decorative icons for the listings. It can either be a + ;; procedure which gets passed one of the icon tags in TAG->ICON and + ;; is expected to return a link pointing to the icon. If it is a + ;; string, that is taken as prefix to which the names from TAG->ICON + ;; are appended. + (icon-name httpd-options-icon-name + set-httpd-options-icon-name!) (fqdn httpd-options-fqdn set-httpd-options-fqdn!) (reported-port httpd-options-reported-port @@ -38,15 +47,16 @@ (define (make-httpd-options) (really-make-httpd-options 80 ; port "/" ; root-directory + #f ; icon-name #f ; fqdn #f ; reported-port #f ; path-handler #f ; server-admin #f ; simultaneous-requests - "/logfile.log" ; name of the logfile - ; string: filename of logfile (directory must exist) - ; output-port: log to this port (e.g. (current-error-port)) - ; #f: no logging + #f + ; string: filename of logfile (directory must exist) + ; output-port: log to this port (e.g. (current-error-port)) + ; #f: no logging #t ; Do syslogging? #t)) ; Write host names instead of IPs in logfiles? @@ -58,6 +68,8 @@ (httpd-options-port options)) (set-httpd-options-root-directory! new-options (httpd-options-root-directory options)) + (set-httpd-options-icon-name! new-options + (httpd-options-icon-name options)) (set-httpd-options-fqdn! new-options (httpd-options-fqdn options)) (set-httpd-options-reported-port! new-options @@ -91,6 +103,8 @@ (make-httpd-options-transformer set-httpd-options-port!)) (define with-root-directory (make-httpd-options-transformer set-httpd-options-root-directory!)) +(define with-icon-name + (make-httpd-options-transformer set-httpd-options-icon-name!)) (define with-fqdn (make-httpd-options-transformer set-httpd-options-fqdn!)) (define with-reported-port diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm new file mode 100644 index 0000000..731454f --- /dev/null +++ b/scheme/httpd/response.scm @@ -0,0 +1,18 @@ +(define-record-type :http-response + (make-response code message seconds mime extras body) + response? + (code response-code) + (message response-message) + (seconds response-seconds) + (mime response-mime) + (extras response-extras) + (body response-body)) + +(define-record-type :http-writer-body + (make-writer-body proc) + writer-body? + (proc writer-body-proc)) + +(define (display-http-body body port options) + ((writer-body-proc body) port options)) + diff --git a/scheme/httpd/text-generation.scm b/scheme/httpd/text-generation.scm index 1339d00..ed21c04 100644 --- a/scheme/httpd/text-generation.scm +++ b/scheme/httpd/text-generation.scm @@ -4,16 +4,7 @@ (define (time->http-date-string time) (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0))) -;;; Output the first chunk of a reply header. - -(define (begin-http-header out reply-code) - (format out "~A ~d ~A\r~%" - server/protocol reply-code (reply-code->text reply-code)) - (format out "Date: ~A\r~%" (time->http-date-string (time))) - (format out "Server: ~A\r~%" server/version)) - -(define (title-html out message new-protocol?) - (if new-protocol? (write-crlf out)) ; Separate html from headers. +(define (title-html out message) (format out "~%~%~A~%~%~%~%" message) (format out "~%

~A

~%" message)) diff --git a/scheme/packages.scm b/scheme/packages.scm index 116b023..32dd99f 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -249,11 +249,12 @@ (define-interface httpd-core-interface (export httpd - send-http-error-reply)) + make-http-error-response)) (define-interface httpd-make-options-interface (export with-port with-root-directory + with-icon-name with-fqdn with-reported-port with-path-handler @@ -266,6 +267,7 @@ (define-interface httpd-read-options-interface (export httpd-options-port httpd-options-root-directory + httpd-options-icon-name httpd-options-fqdn httpd-options-reported-port httpd-options-path-handler @@ -349,29 +351,34 @@ (define-interface httpd-text-generation-interface (export time->http-date-string - begin-http-header title-html)) +(define-interface httpd-responses-interface + (export make-response response? + response-code + response-message + response-seconds + response-mime + response-extras + response-body + + make-writer-body writer-body? + display-http-body)) + (define-interface httpd-basic-handlers-interface (export make-request-handler make-path-handler make-hostname-handler make-path-prefix-handler - alist-path-dispatcher - home-dir-handler + alist-path-dispatcher)) + +(define-interface httpd-file-directory-handlers-interface + (export home-dir-handler tilde-home-dir-handler tilde-home-dir-handler-predicate rooted-file-handler rooted-file-or-directory-handler - null-path-handler - serve-rooted-file-path - file-serve - file-server-and-dir - http-homedir - send-file - dotdot-check - file-extension->content-type - copy-inport->outport)) + null-path-handler)) (define-interface seval-handler-interface (export seval-handler)) @@ -658,6 +665,8 @@ httpd-logging httpd-request httpd-reply-codes + httpd-constants + httpd-responses httpd-text-generation scheme) (files (httpd core))) @@ -725,23 +734,37 @@ scsh) ; format-date (files (httpd text-generation))) +(define-structure httpd-responses httpd-responses-interface + (open scheme + srfi-9) + (files (httpd response))) + (define-structure httpd-basic-handlers httpd-basic-handlers-interface - (open scsh ; syscalls - formats ; FORMAT + (open scheme scsh httpd-request ; REQUEST record type, v0.9-request - httpd-reply-codes ; reply codes - httpd-text-generation ; begin-http-header - httpd-error ; HTTP-ERROR - htmlout - conditions ; CONDITION-STUFF - url ; HTTP-URL record type - handle-fatal-error ; WITH-FATAL-ERROR-HANDLER - string-lib ; STRING-JOIN - list-lib ; FOLD-RIGHT - rfc822 ; GET-HEADER - scheme) + srfi-1 ; FOLD-RIGHT + srfi-13 ; STRING-TRIM + ) (files (httpd handlers))) +(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface + (open scheme scsh + httpd-core + httpd-request + httpd-reply-codes + httpd-responses + httpd-text-generation + httpd-error + httpd-read-options + url + htmlout + crlf-io + srfi-13 ; STRING-JOIN + conditions + handle-fatal-error + ) + (files (httpd file-dir-handler))) + (define-structure seval-handler seval-handler-interface (open scsh ; syscalls & INDEX httpd-error