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

* Move error handling of the servlets to the right point, i.e. after 

the reset.
* Remove redirect 'feature'. It is not well tought out.
This commit is contained in:
interp 2002-10-26 15:35:20 +00:00
parent ddae6cfb3c
commit 26683bd822
1 changed files with 31 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -79,8 +79,9 @@
(lambda () (lambda ()
(random-integer 1073741824)))) ; I hope, 1+ billion is enough.... (random-integer 1073741824)))) ; I hope, 1+ billion is enough....
;; servlet-prefix gives virtual prefixed path to servlets ;; Servlet-prefix gives virtual prefixed path to servlets. Currently,
(define (servlet-handler servlet-path servlet-prefix) ;; it is ignored.
(define (servlet-handler servlet-path . servlet-prefix)
(set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix)) (set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix))
(lambda (path req) (lambda (path req)
(if (pair? path) ; need at least one element (if (pair? path) ; need at least one element
@ -89,26 +90,19 @@
(if (or (string=? request-method "GET") (if (or (string=? request-method "GET")
(string=? request-method "POST")) (string=? request-method "POST"))
(let ((response (let ((response
(call-with-current-continuation
(lambda (exit)
(with-handler
(lambda (condition more)
(exit
(make-http-error-response
http-status/bad-gateway req
(format #f "Internal error while executing servlet ~s." path)
condition)))
(lambda ()
(if (resume-url? path-string) (if (resume-url? path-string)
(resume-url path-string servlet-path req) (resume-url path-string servlet-path req)
(launch-new-instance path-string servlet-path req)))))))) (launch-new-instance path-string servlet-path req))))
(if (redirect-body? (response-body response)) ; (if (redirect-body? (response-body response))
;; Pefix it with servlet-prefix. ; (let ((target (redirect-body-location (response-body response))))
(make-redirect-response ; (if (relative? target)
(path-list->file-name ; ;; Pefix it with servlet-prefix.
(list (directory-as-file-name servlet-prefix) ; (make-redirect-response
(redirect-body-location (response-body response))))) ; (path-list->file-name
response)) ; (list (directory-as-file-name servlet-prefix)
; target)))
; response))
response)
(make-http-error-response http-status/method-not-allowed req (make-http-error-response http-status/method-not-allowed req
request-method))) request-method)))
(make-http-error-response http-status/bad-request req (make-http-error-response http-status/bad-request req
@ -144,12 +138,21 @@
(options-instance-lifetime)) (options-instance-lifetime))
memo)) memo))
(reset (reset
(begin (call-with-current-continuation
(lambda (exit)
(with-handler
(lambda (condition more)
(exit
(make-http-error-response
http-status/bad-gateway req
(format #f "Internal error while executing servlet ~s." path-string)
condition)))
(lambda ()
(with-cwd (with-cwd
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. (else ; We'll serve every non-scm file.
;; We need access to SEND-FILE-RESPONSE of ;; We need access to SEND-FILE-RESPONSE of
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
@ -544,8 +547,6 @@
result)) result))
(define (debug fmt . args) (define (debug fmt . args)
(if *debug* (if *debug*
(format #t "DEBUG: ~?~%" fmt args) (format #t "DEBUG: ~?~%" fmt args)