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
sxml-to-html ;SXML->HTML
scsh ;regexp et al.
; httpd-file-directory-handlers ;send-file-response
scheme
)
(files servlet-handler))

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

@ -107,39 +107,52 @@
(format #f "Bad path: ~s" path)))))
(define (launch-new-instance path-string servlet-path req)
(if (file-not-exists? (absolute-file-name path-string servlet-path))
(make-http-error-response http-status/not-found req path-string)
(begin
(obtain-lock *instance-table-lock*)
;; no access to instance table until new instance-id is saved
(let ((instance-id (generate-new-table-id *instance-table*))
(memo (make-memo)))
(table-set! *instance-table* instance-id
(make-instance path-string ; used to make
; redirections to origin
memo
(make-integer-table) ; continuation table
(make-lock) ; continuation table lock
(make-thread-safe-counter))) ; continuation counter
(release-lock *instance-table-lock*)
(register-session! instance-id 'no-return)
(let ((servlet (with-fatal-error-handler*
(lambda (condition decline)
(delete-instance! instance-id)
(decline))
(lambda ()
(get-servlet-rt-structure path-string servlet-path)))))
(fork-thread (instance-surveillance instance-id
(+ (time)
(options-instance-lifetime))
memo))
(reset
(begin
(with-cwd
servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(main req))))))))))
(cond
((file-not-exists? (absolute-file-name path-string servlet-path))
(make-http-error-response http-status/not-found req path-string))
((string=? (file-name-extension path-string) ".scm")
(obtain-lock *instance-table-lock*)
;; no access to instance table until new instance-id is saved
(let ((instance-id (generate-new-table-id *instance-table*))
(memo (make-memo)))
(table-set! *instance-table* instance-id
(make-instance path-string ; used to make
; redirections to origin
memo
(make-integer-table) ; continuation table
(make-lock) ; continuation table lock
(make-thread-safe-counter))) ; continuation counter
(release-lock *instance-table-lock*)
(register-session! instance-id 'no-return)
(let ((servlet
(with-fatal-error-handler
(lambda (condition decline)
(delete-instance! instance-id)
(decline))
(get-servlet-rt-structure path-string servlet-path))))
(fork-thread (instance-surveillance instance-id
(+ (time)
(options-instance-lifetime))
memo))
(reset
(begin
(with-cwd
servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(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)
(lambda ()