scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- 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.
This commit is contained in:
sperber 2003-01-29 10:08:25 +00:00
parent 730053c6bc
commit 6e5f9ed278
5 changed files with 81 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
doc/latex/httpd.tex
View File

@ -493,26 +493,29 @@ one. Here they are:
\begin{desc} \begin{desc}
This specifies a procedure for determining the icon to be displayed This specifies a procedure for determining the icon to be displayed
next to a file name in a directory listing. next to a file name in a directory listing.
\var{Proc} takes a file name as an argument and must return a URI \var{Proc} takes a file name as an argument and must return a URL
representing the corresponding icon. for the corresponding icon or \sharpf.
\end{desc} \end{desc}
\defun{with-blank-icon-url}{file-name [options]}{options} \defun{with-blank-icon-url}{file-name-or-\sharpf{} [options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that must be as wide This specifies a file name (or its absence) for the special icon
as the icons returned by the previous procedure but that is blank. that must be as wide as the icons returned by the previous procedure
but that is blank.
\end{desc} \end{desc}
\defun{with-back-icon-url}{file-name [options]}{options} \defun{with-back-icon-url}{file-name-or-\sharpf{} [options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that is displayed This specifies a file name (or its absence) for the special icon
next to the ``parent directory'' link in directory listings. that is displayed next to the ``parent directory'' link in directory
listings.
\end{desc} \end{desc}
\defun{with-unknown-icon-url}{file-name [options]}{options} \defun{with-unknown-icon-url}{file-name-or-\sharpf{}
[options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that is displayed This specifies a file name (or its absence) for the special icon
next to the unknown entries in directory listings. that is displayed next to the unknown entries in directory listings.
\end{desc} \end{desc}
The \ex{make-file-directory-options} procedure eases the construction 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: 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} \begin{desc}
This returns a request handler that serves files from a particular This returns a request handler that serves files from a particular
root in the file system. Only the \ex{GET} operation is provided. 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. Otherwise, the file is served to the client.
\end{desc} \end{desc}
\defun{rooted-file-or-directory-handler}{root options}{request-handler} \defun{rooted-file-or-directory-handler}{root [options]}{request-handler}
\begin{desc} \begin{desc}
Dito, but also serve directory indices for directories without Dito, but also serve directory indices for directories without
\ex{index.html}. \ex{index.html}.
\end{desc} \end{desc}
\defun{home-dir-handler}{subdir options}{request-handler} \defun{home-dir-handler}{subdir [options]}{request-handler}
\begin{desc} \begin{desc}
This procedure builds a request handler that does basic file serving This procedure builds a request handler that does basic file serving
out of home directories. If the resulting \var{request-handler} is 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. allowed to contain \ex{..} elements.
\end{desc} \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} \begin{desc}
This returns request handler that examines the car of the path. If 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 it is a string beginning with a tilde, e.g., \ex{"~ziggy"}, then the

141
scheme/httpd/file-dir-handler.scm
View File

@ -37,10 +37,7 @@
(really-make-file-directory-options default-file-name->content-type (really-make-file-directory-options default-file-name->content-type
default-file-name->content-encoding default-file-name->content-encoding
default-file-name->icon-url default-file-name->icon-url
"directory.xbm" #f #f #f #f))
"blank.xbm"
"back.xbm"
"unknown.xbm"))
(define (copy-file-directory-options options) (define (copy-file-directory-options options)
(let ((new-options (make-default-file-directory-options))) (let ((new-options (make-default-file-directory-options)))
@ -117,19 +114,20 @@
;;; serving ;;; serving
;;; ~<user>/<user-public-dir>/<file-path> ;;; ~<user>/<user-public-dir>/<file-path>
(define (home-dir-handler user-public-dir options) (define (home-dir-handler user-public-dir . maybe-options)
(lambda (path req) (let-optionals maybe-options ((options (make-default-file-directory-options)))
(if (null? path) (lambda (path req)
(make-error-response (status-code bad-request) (if (null? path)
req (make-error-response (status-code bad-request)
"Path contains no home directory.") req
(make-rooted-file-path-response (string-append (http-homedir (car path) req) "Path contains no home directory.")
"/" (make-rooted-file-path-response (string-append (http-homedir (car path) req)
user-public-dir) "/"
(cdr path) user-public-dir)
file-serve-response (cdr path)
req file-serve-response
options)))) req
options)))))
;;; (tilde-home-dir-handler user-public-dir default-request-handler) ;;; (tilde-home-dir-handler user-public-dir default-request-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -143,38 +141,41 @@
(and (> (string-length head) 0) (and (> (string-length head) 0)
(char=? (string-ref head 0) #\~))))) (char=? (string-ref head 0) #\~)))))
(define (tilde-home-dir-handler user-public-dir default-handler options) (define (tilde-home-dir-handler user-public-dir default-handler . maybe-options)
(make-predicate-handler (let-optionals maybe-options ((options (make-default-file-directory-options)))
tilde-home-dir? (make-predicate-handler
(lambda (path req) tilde-home-dir?
(let* ((tilde-home (car path)) ; Yes. (lambda (path req)
(slen (string-length tilde-home)) (let* ((tilde-home (car path)) ; Yes.
(subdir (string-append (slen (string-length tilde-home))
(http-homedir (substring tilde-home 1 slen) req) (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 user-public-dir)))
options))) (make-rooted-file-path-response subdir (cdr path) file-serve-response req
default-handler)) options)))
default-handler)))
;;; Make a handler that serves files relative to a particular root ;;; 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 ;;; in the file system. You may follow symlinks, but you can't back up
;;; past ROOT with ..'s. ;;; past ROOT with ..'s.
(define (rooted-file-handler root options) (define (rooted-file-handler root . maybe-options)
(lambda (path req) (let-optionals maybe-options ((options (make-default-file-directory-options)))
(make-rooted-file-path-response root path file-serve-response req 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 ;;; Dito, but also serve directory indices for directories without
;;; index.html. ;;; index.html.
(define (rooted-file-or-directory-handler root options) (define (rooted-file-or-directory-handler root . maybe-options)
(lambda (path req) (let-optionals maybe-options ((options (make-default-file-directory-options)))
(make-rooted-file-path-response root path (lambda (path req)
file-serve-and-dir-response (make-rooted-file-path-response root path
req file-serve-and-dir-response
options))) req
options))))
;;;; Support procs for the path handlers ;;;; Support procs for the path handlers
@ -271,44 +272,8 @@
directory-index-serve-response directory-index-serve-response
options)) 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) (define (default-file-name->icon-url fname)
(let ((ext (file-name-extension fname))) #f)
(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"))))
(define (time->directory-index-date-string time) (define (time->directory-index-date-string time)
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0))) (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
@ -395,9 +360,11 @@
((regular fifo socket) "[FILE]") ((regular fifo socket) "[FILE]")
((directory) "[DIR ]") ((directory) "[DIR ]")
(else "[????]")))) (else "[????]"))))
(emit-tag port 'img (if icon-name
(cons 'src icon-name) (emit-tag port 'img
(cons 'alt tag-name)) (cons 'src icon-name)
(cons 'alt tag-name))
(display tag-name port))
(with-tag port a ((href file)) (with-tag port a ((href file))
(emit-file-name file)) (emit-file-name file))
(pad-file-name file) (pad-file-name file)
@ -456,17 +423,21 @@
(with-tag port body () (with-tag port body ()
(emit-header port 1 title) (emit-header port 1 title)
(with-tag port pre () (with-tag port pre ()
(emit-tag port 'img (if blank-icon
(cons 'src blank-icon) (display "[ ]" port)
(cons 'alt " ")) (emit-tag port 'img
(cons 'src blank-icon)
(cons 'alt " ")))
(write-string "Name " port) (write-string "Name " port)
(write-string "Last modified " port) (write-string "Last modified " port)
(write-string "Size " port) (write-string "Size " port)
(write-string "Description" port) (write-string "Description" port)
(emit-tag port 'hr) (emit-tag port 'hr)
(emit-tag port 'img (if back-icon
(cons 'src back-icon) (emit-tag port 'img
(cons 'alt "[UP ]")) (cons 'src back-icon)
(cons 'alt "[UP ]"))
(display "[UP ]" port))
(if (not (null? file-path)) (if (not (null? file-path))
(begin (begin
(with-tag port a ((href "..")) (with-tag port a ((href ".."))

13
scheme/httpd/http-top.scm
View File

@ -15,11 +15,10 @@
(define rh1 (define rh1
(alist-path-dispatcher (alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options))) `(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler) ("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(rooted-file-handler "/usr/local/etc/httpd/htdocs" (rooted-file-handler "/usr/local/etc/httpd/htdocs")))
(make-file-directory-options))))
;;; Do a rough approximation of NCSA httpd server semantics: ;;; Do a rough approximation of NCSA httpd server semantics:
@ -32,9 +31,7 @@
(alist-path-dispatcher (alist-path-dispatcher
`(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) `(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html" (tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs" (rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(make-file-directory-options))
(make-file-directory-options))))
;;; Greatest hits request handler. ;;; Greatest hits request handler.
@ -44,9 +41,7 @@
("seval" . ,seval-handler) ("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html" (tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs" (rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(make-file-directory-options))
(make-file-directory-options))))

6
scheme/httpd/server.scm
View File

@ -24,13 +24,11 @@ exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
(define rh (define rh
(alist-path-dispatcher (alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options))) `(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler) ("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html" (tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs" (rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(make-file-directory-options))
(make-file-directory-options))))

1
scheme/packages.scm
View File

@ -680,6 +680,7 @@
(subset rfc822 (rfc822-time->string)) (subset rfc822 (rfc822-time->string))
sunet-utilities ; dotdot-check, copy-inport->outport sunet-utilities ; dotdot-check, copy-inport->outport
conditions conditions
let-opt
handle-fatal-error handle-fatal-error
) )
(files (httpd file-dir-handler))) (files (httpd file-dir-handler)))