From 6e5f9ed278ff9c8b38a295e3d8dc331806a5e21a Mon Sep 17 00:00:00 2001 From: sperber Date: Wed, 29 Jan 2003 10:08:25 +0000 Subject: [PATCH] - Make the handlers in HTTPD-FILE-DIRECTORY-HANDLERS do something sensible without a set of icons. - Make the options arguments to the handlers in HTTPD-FILE-DIRECTORY-HANDLERS optional. --- doc/latex/httpd.tex | 33 +++---- scheme/httpd/file-dir-handler.scm | 141 ++++++++++++------------------ scheme/httpd/http-top.scm | 13 +-- scheme/httpd/server.scm | 6 +- scheme/packages.scm | 1 + 5 files changed, 81 insertions(+), 113 deletions(-) diff --git a/doc/latex/httpd.tex b/doc/latex/httpd.tex index 7fc3c3b..b93b113 100644 --- a/doc/latex/httpd.tex +++ b/doc/latex/httpd.tex @@ -493,26 +493,29 @@ one. Here they are: \begin{desc} This specifies a procedure for determining the icon to be displayed next to a file name in a directory listing. - \var{Proc} takes a file name as an argument and must return a URI - representing the corresponding icon. + \var{Proc} takes a file name as an argument and must return a URL + for the corresponding icon or \sharpf. \end{desc} -\defun{with-blank-icon-url}{file-name [options]}{options} +\defun{with-blank-icon-url}{file-name-or-\sharpf{} [options]}{options} \begin{desc} - This specifies a file name for the special icon that must be as wide - as the icons returned by the previous procedure but that is blank. + This specifies a file name (or its absence) for the special icon + that must be as wide as the icons returned by the previous procedure + but that is blank. \end{desc} -\defun{with-back-icon-url}{file-name [options]}{options} +\defun{with-back-icon-url}{file-name-or-\sharpf{} [options]}{options} \begin{desc} - This specifies a file name for the special icon that is displayed - next to the ``parent directory'' link in directory listings. + This specifies a file name (or its absence) for the special icon + that is displayed next to the ``parent directory'' link in directory + listings. \end{desc} -\defun{with-unknown-icon-url}{file-name [options]}{options} +\defun{with-unknown-icon-url}{file-name-or-\sharpf{} + [options]}{options} \begin{desc} - This specifies a file name for the special icon that is displayed - next to the unknown entries in directory listings. + This specifies a file name (or its absence) for the special icon + that is displayed next to the unknown entries in directory listings. \end{desc} The \ex{make-file-directory-options} procedure eases the construction @@ -529,7 +532,7 @@ of the options argument: % Here are procedure for constructing static content request handlers: % -\defun{rooted-file-handler}{root options}{request-handler} +\defun{rooted-file-handler}{root [options]}{request-handler} \begin{desc} This returns a request handler that serves files from a particular root in the file system. Only the \ex{GET} operation is provided. @@ -539,13 +542,13 @@ Here are procedure for constructing static content request handlers: Otherwise, the file is served to the client. \end{desc} -\defun{rooted-file-or-directory-handler}{root options}{request-handler} +\defun{rooted-file-or-directory-handler}{root [options]}{request-handler} \begin{desc} Dito, but also serve directory indices for directories without \ex{index.html}. \end{desc} -\defun{home-dir-handler}{subdir options}{request-handler} +\defun{home-dir-handler}{subdir [options]}{request-handler} \begin{desc} This procedure builds a request handler that does basic file serving out of home directories. If the resulting \var{request-handler} is @@ -556,7 +559,7 @@ Dito, but also serve directory indices for directories without allowed to contain \ex{..} elements. \end{desc} -\defun{tilde-home-dir-handler}{subdir default-request-handler options}{request-handler} +\defun{tilde-home-dir-handler}{subdir default-request-handler [options]}{request-handler} \begin{desc} This returns request handler that examines the car of the path. If it is a string beginning with a tilde, e.g., \ex{"~ziggy"}, then the diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm index 94f5394..469484b 100644 --- a/scheme/httpd/file-dir-handler.scm +++ b/scheme/httpd/file-dir-handler.scm @@ -37,10 +37,7 @@ (really-make-file-directory-options default-file-name->content-type default-file-name->content-encoding default-file-name->icon-url - "directory.xbm" - "blank.xbm" - "back.xbm" - "unknown.xbm")) + #f #f #f #f)) (define (copy-file-directory-options options) (let ((new-options (make-default-file-directory-options))) @@ -117,19 +114,20 @@ ;;; serving ;;; ~// -(define (home-dir-handler user-public-dir options) - (lambda (path req) - (if (null? path) - (make-error-response (status-code bad-request) - req - "Path contains no home directory.") - (make-rooted-file-path-response (string-append (http-homedir (car path) req) - "/" - user-public-dir) - (cdr path) - file-serve-response - req - options)))) +(define (home-dir-handler user-public-dir . maybe-options) + (let-optionals maybe-options ((options (make-default-file-directory-options))) + (lambda (path req) + (if (null? path) + (make-error-response (status-code bad-request) + req + "Path contains no home directory.") + (make-rooted-file-path-response (string-append (http-homedir (car path) req) + "/" + user-public-dir) + (cdr path) + file-serve-response + req + options))))) ;;; (tilde-home-dir-handler user-public-dir default-request-handler) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -143,38 +141,41 @@ (and (> (string-length head) 0) (char=? (string-ref head 0) #\~))))) -(define (tilde-home-dir-handler user-public-dir default-handler options) - (make-predicate-handler - tilde-home-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 - options))) - default-handler)) +(define (tilde-home-dir-handler user-public-dir default-handler . maybe-options) + (let-optionals maybe-options ((options (make-default-file-directory-options))) + (make-predicate-handler + tilde-home-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 + options))) + default-handler))) ;;; 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 options) - (lambda (path req) - (make-rooted-file-path-response root path file-serve-response req options))) +(define (rooted-file-handler root . maybe-options) + (let-optionals maybe-options ((options (make-default-file-directory-options))) + (lambda (path req) + (make-rooted-file-path-response root path file-serve-response req options)))) ;;; Dito, but also serve directory indices for directories without ;;; index.html. -(define (rooted-file-or-directory-handler root options) - (lambda (path req) - (make-rooted-file-path-response root path - file-serve-and-dir-response - req - options))) +(define (rooted-file-or-directory-handler root . maybe-options) + (let-optionals maybe-options ((options (make-default-file-directory-options))) + (lambda (path req) + (make-rooted-file-path-response root path + file-serve-and-dir-response + req + options)))) ;;;; Support procs for the path handlers @@ -271,44 +272,8 @@ directory-index-serve-response options)) -;; These icons can, for example, be found in the cern-httpd-3.0 -;; distribution at http://www.w3.org/pub/WWW/Daemon/ - (define (default-file-name->icon-url fname) - (let ((ext (file-name-extension fname))) - (cond - ((string-ci=? ext ".txt") "text.xbm") - ((or (string-ci=? ext ".doc") - (string-ci=? ext ".htm") - (string-ci=? ext ".html") - (string-ci=? ext ".rtf") - (string-ci=? ext ".pdf") - (string-ci=? ext ".dvi") - (string-ci=? ext ".ps") - (string-ci=? ext ".tex")) "doc.xbm") - ((or (string-ci=? ext ".bmp") - (string-ci=? ext ".gif") - (string-ci=? ext ".png") - (string-ci=? ext ".jpg") - (string-ci=? ext ".jpeg") - (string-ci=? ext ".tiff") - (string-ci=? ext ".tif")) "image.xbm") - ((or (string-ci=? ext ".mpeg") - (string-ci=? ext ".mpg")) "movie.xbm") - ((or (string-ci=? ext ".au") - (string-ci=? ext ".snd") - (string-ci=? ext ".mp3") - (string-ci=? ext ".wav")) "sound.xbm") - ((or (string-ci=? ext ".tar") - (string-ci=? ext ".zip") - (string-ci=? ext ".zoo")) "tar.xbm") - ((or (string-ci=? ext ".gz") - (string-ci=? ext ".bz2") - (string-ci=? ext ".Z") - (string-ci=? ext ".z")) "compressed.xbm") - ((string-ci=? ext ".uu") "uu.xbm") - ((string-ci=? ext ".hqx") "binhex.xbm") - (else "binary.xbm")))) + #f) (define (time->directory-index-date-string time) (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0))) @@ -395,9 +360,11 @@ ((regular fifo socket) "[FILE]") ((directory) "[DIR ]") (else "[????]")))) - (emit-tag port 'img - (cons 'src icon-name) - (cons 'alt tag-name)) + (if icon-name + (emit-tag port 'img + (cons 'src icon-name) + (cons 'alt tag-name)) + (display tag-name port)) (with-tag port a ((href file)) (emit-file-name file)) (pad-file-name file) @@ -456,17 +423,21 @@ (with-tag port body () (emit-header port 1 title) (with-tag port pre () - (emit-tag port 'img - (cons 'src blank-icon) - (cons 'alt " ")) + (if blank-icon + (display "[ ]" port) + (emit-tag port 'img + (cons 'src blank-icon) + (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 back-icon) - (cons 'alt "[UP ]")) + (if back-icon + (emit-tag port 'img + (cons 'src back-icon) + (cons 'alt "[UP ]")) + (display "[UP ]" port)) (if (not (null? file-path)) (begin (with-tag port a ((href "..")) diff --git a/scheme/httpd/http-top.scm b/scheme/httpd/http-top.scm index 18f0a85..908f064 100644 --- a/scheme/httpd/http-top.scm +++ b/scheme/httpd/http-top.scm @@ -15,11 +15,10 @@ (define rh1 (alist-path-dispatcher - `(("h" . ,(home-dir-handler "public_html" (make-file-directory-options))) + `(("h" . ,(home-dir-handler "public_html")) ("seval" . ,seval-handler) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) - (rooted-file-handler "/usr/local/etc/httpd/htdocs" - (make-file-directory-options)))) + (rooted-file-handler "/usr/local/etc/httpd/htdocs"))) ;;; Do a rough approximation of NCSA httpd server semantics: @@ -32,9 +31,7 @@ (alist-path-dispatcher `(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) (tilde-home-dir-handler "public_html" - (rooted-file-handler "/usr/local/etc/httpd/htdocs" - (make-file-directory-options)) - (make-file-directory-options)))) + (rooted-file-handler "/usr/local/etc/httpd/htdocs")))) ;;; Greatest hits request handler. @@ -44,9 +41,7 @@ ("seval" . ,seval-handler) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) (tilde-home-dir-handler "public_html" - (rooted-file-handler "/usr/local/etc/httpd/htdocs" - (make-file-directory-options)) - (make-file-directory-options)))) + (rooted-file-handler "/usr/local/etc/httpd/htdocs")))) diff --git a/scheme/httpd/server.scm b/scheme/httpd/server.scm index ba017a9..ac8fa62 100755 --- a/scheme/httpd/server.scm +++ b/scheme/httpd/server.scm @@ -24,13 +24,11 @@ exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@" (define rh (alist-path-dispatcher - `(("h" . ,(home-dir-handler "public_html" (make-file-directory-options))) + `(("h" . ,(home-dir-handler "public_html")) ("seval" . ,seval-handler) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) (tilde-home-dir-handler "public_html" - (rooted-file-handler "/usr/local/etc/httpd/htdocs" - (make-file-directory-options)) - (make-file-directory-options)))) + (rooted-file-handler "/usr/local/etc/httpd/htdocs")))) diff --git a/scheme/packages.scm b/scheme/packages.scm index fe946af..886cb7f 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -680,6 +680,7 @@ (subset rfc822 (rfc822-time->string)) sunet-utilities ; dotdot-check, copy-inport->outport conditions + let-opt handle-fatal-error ) (files (httpd file-dir-handler)))