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)
(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)
"/"
user-public-dir)
(cdr path)
file-serve-response
req)
(make-http-error-response http-status/bad-request
req
"Path contains no home directory."))))
req))))
;;; (tilde-home-dir-handler-predicate path)
;;; (tilde-home-dir-handler user-public-dir)
;;; (tilde-home-dir-handler user-public-dir default-path-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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? path req)
(and (not (null? path))
(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))))
(define (tilde-home-dir-handler user-public-dir default-ph)
(make-request-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)))
default-ph))
;;; 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
(export home-dir-handler
tilde-home-dir-handler
tilde-home-dir-handler-predicate
rooted-file-handler
rooted-file-or-directory-handler
null-path-handler))
@ -771,6 +770,7 @@
httpd-request
httpd-responses
httpd-error
httpd-basic-handlers
httpd-read-options
url
htmlout