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

add possibility to serve non-Scheme files

This commit is contained in:
interp 2002-10-02 23:47:07 +00:00
parent 4899ff0453
commit f9f854ef85
2 changed files with 47 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/httpd/surflets/packages.scm
View File

@ -121,6 +121,7 @@
thread-fluids ;FORK-THREAD thread-fluids ;FORK-THREAD
sxml-to-html ;SXML->HTML sxml-to-html ;SXML->HTML
scsh ;regexp et al. scsh ;regexp et al.
; httpd-file-directory-handlers ;send-file-response
scheme scheme
) )
(files servlet-handler)) (files servlet-handler))

27
scheme/httpd/surflets/surflet-handler.scm
View File

@ -107,9 +107,10 @@
(format #f "Bad path: ~s" path))))) (format #f "Bad path: ~s" path)))))
(define (launch-new-instance path-string servlet-path req) (define (launch-new-instance path-string servlet-path req)
(if (file-not-exists? (absolute-file-name path-string servlet-path)) (cond
(make-http-error-response http-status/not-found req path-string) ((file-not-exists? (absolute-file-name path-string servlet-path))
(begin (make-http-error-response http-status/not-found req path-string))
((string=? (file-name-extension path-string) ".scm")
(obtain-lock *instance-table-lock*) (obtain-lock *instance-table-lock*)
;; no access to instance table until new instance-id is saved ;; no access to instance table until new instance-id is saved
(let ((instance-id (generate-new-table-id *instance-table*)) (let ((instance-id (generate-new-table-id *instance-table*))
@ -123,12 +124,12 @@
(make-thread-safe-counter))) ; continuation counter (make-thread-safe-counter))) ; continuation counter
(release-lock *instance-table-lock*) (release-lock *instance-table-lock*)
(register-session! instance-id 'no-return) (register-session! instance-id 'no-return)
(let ((servlet (with-fatal-error-handler* (let ((servlet
(with-fatal-error-handler
(lambda (condition decline) (lambda (condition decline)
(delete-instance! instance-id) (delete-instance! instance-id)
(decline)) (decline))
(lambda () (get-servlet-rt-structure path-string servlet-path))))
(get-servlet-rt-structure path-string servlet-path)))))
(fork-thread (instance-surveillance instance-id (fork-thread (instance-surveillance instance-id
(+ (time) (+ (time)
(options-instance-lifetime)) (options-instance-lifetime))
@ -139,7 +140,19 @@
servlet-path servlet-path
(with-names-from-rt-structure (with-names-from-rt-structure
servlet servlet-interface servlet servlet-interface
(main req)))))))))) (main req))))))))
(else ; We'll serve every non-scm file.
;; We need access to SEND-FILE-RESPONSE of
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
;; don't have it, so we disable this feature here.
; (let ((full-file-name (absolute-file-name path-string servlet-path)))
; (send-file-response full-file-name
; (file-info full-file-name)
; req))
(make-http-error-response http-status/forbidden req
"Can't serve other than Scheme files."
path-string))
))
(define (instance-surveillance instance-id time-to-die memo) (define (instance-surveillance instance-id time-to-die memo)
(lambda () (lambda ()