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

61
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 (if (resume-url? path-string)
(lambda (exit) (resume-url path-string servlet-path req)
(with-handler (launch-new-instance path-string servlet-path req))))
(lambda (condition more) ; (if (redirect-body? (response-body response))
(exit ; (let ((target (redirect-body-location (response-body response))))
(make-http-error-response ; (if (relative? target)
http-status/bad-gateway req ; ;; Pefix it with servlet-prefix.
(format #f "Internal error while executing servlet ~s." path) ; (make-redirect-response
condition))) ; (path-list->file-name
(lambda () ; (list (directory-as-file-name servlet-prefix)
(if (resume-url? path-string) ; target)))
(resume-url path-string servlet-path req) ; response))
(launch-new-instance path-string servlet-path req)))))))) response)
(if (redirect-body? (response-body response))
;; Pefix it with servlet-prefix.
(make-redirect-response
(path-list->file-name
(list (directory-as-file-name servlet-prefix)
(redirect-body-location (response-body 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
(with-cwd (lambda (exit)
servlet-path (with-handler
(with-names-from-rt-structure (lambda (condition more)
servlet servlet-interface (exit
(main req)))))))) (make-http-error-response
http-status/bad-gateway req
(format #f "Internal error while executing servlet ~s." path-string)
condition)))
(lambda ()
(with-cwd
servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(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)