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 ()
(random-integer 1073741824)))) ; I hope, 1+ billion is enough....
;; servlet-prefix gives virtual prefixed path to servlets
(define (servlet-handler servlet-path servlet-prefix)
;; Servlet-prefix gives virtual prefixed path to servlets. Currently,
;; it is ignored.
(define (servlet-handler servlet-path . servlet-prefix)
(set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix))
(lambda (path req)
(if (pair? path) ; need at least one element
@ -89,26 +90,19 @@
(if (or (string=? request-method "GET")
(string=? request-method "POST"))
(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)
(resume-url path-string servlet-path req)
(launch-new-instance path-string servlet-path req))))))))
(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))
(if (resume-url? path-string)
(resume-url path-string servlet-path req)
(launch-new-instance path-string servlet-path req))))
; (if (redirect-body? (response-body response))
; (let ((target (redirect-body-location (response-body response))))
; (if (relative? target)
; ;; Pefix it with servlet-prefix.
; (make-redirect-response
; (path-list->file-name
; (list (directory-as-file-name servlet-prefix)
; target)))
; response))
response)
(make-http-error-response http-status/method-not-allowed req
request-method)))
(make-http-error-response http-status/bad-request req
@ -144,12 +138,21 @@
(options-instance-lifetime))
memo))
(reset
(begin
(with-cwd
servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(main req))))))))
(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
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
@ -544,8 +547,6 @@
result))
(define (debug fmt . args)
(if *debug*
(format #t "DEBUG: ~?~%" fmt args)