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

Fix HOME-DIR-HANDLER and TILDE-HOME-DIR-HANDLER.

This commit is contained in:
sperber 2002-08-27 09:32:12 +00:00
parent 4c98437ce0
commit f5b7f76bd6
2 changed files with 24 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24,40 +24,41 @@
(define (home-dir-handler user-public-dir) (define (home-dir-handler user-public-dir)
(lambda (path req) (lambda (path req)
(if (pair? path) (if (null? path)
(make-http-error-response http-status/bad-request
req
"Path contains no home directory.")
(make-rooted-file-path-response (string-append (http-homedir (car path) req) (make-rooted-file-path-response (string-append (http-homedir (car path) req)
"/" "/"
user-public-dir) user-public-dir)
(cdr path) (cdr path)
file-serve-response file-serve-response
req) req))))
(make-http-error-response http-status/bad-request
req
"Path contains no home directory."))))
;;; (tilde-home-dir-handler-predicate path) ;;; (tilde-home-dir-handler user-public-dir default-path-handler)
;;; (tilde-home-dir-handler user-public-dir)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"), ;;; 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 ;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
;;; default handler. ;;; default handler.
(define (tilde-home-dir-handler-predicate path) (define (tilde-home-dir? path req)
(lambda (path) (and (not (null? path))
(and (pair? path) ; Is it a ~foo/... (let ((head (car path))) ; home-directory path?
(let ((head (car path))) ; home-directory path? (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) (define (tilde-home-dir-handler user-public-dir default-ph)
(lambda (path req) (make-request-handler
(let* ((tilde-home (car path)) ; Yes. tilde-home-dir?
(slen (string-length tilde-home)) (lambda (path req)
(subdir (string-append (let* ((tilde-home (car path)) ; Yes.
(http-homedir (substring tilde-home 1 slen) req) (slen (string-length tilde-home))
"/" (subdir (string-append
user-public-dir))) (http-homedir (substring tilde-home 1 slen) req)
(make-rooted-file-path-response subdir (cdr path) file-serve-response req)))) "/"
user-public-dir)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req)))
default-ph))
;;; Make a handler that serves files relative to a particular root ;;; Make a handler that serves files relative to a particular root

2
scheme/packages.scm
View File

@ -374,7 +374,6 @@
(define-interface httpd-file-directory-handlers-interface (define-interface httpd-file-directory-handlers-interface
(export home-dir-handler (export home-dir-handler
tilde-home-dir-handler tilde-home-dir-handler
tilde-home-dir-handler-predicate
rooted-file-handler rooted-file-handler
rooted-file-or-directory-handler rooted-file-or-directory-handler
null-path-handler)) null-path-handler))
@ -771,6 +770,7 @@
httpd-request httpd-request
httpd-responses httpd-responses
httpd-error httpd-error
httpd-basic-handlers
httpd-read-options httpd-read-options
url url
htmlout htmlout