diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index a742ee5..09bf3f7 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -127,6 +127,7 @@ sxml-to-html ;SXML->HTML scsh ;regexp et al. ; httpd-file-directory-handlers ;send-file-response + srfi-6 ;string-ports handle scheme ) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 03cdba3..c54add9 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -246,7 +246,7 @@ session-id continuation-counter continuation-id))) - (response-maker new-url))))) + (make-servlet-response (response-maker new-url)))))) (make-error-response (status-code not-found) #f "The URL refers to a servlet, whose session is no longer alive."))))) @@ -257,6 +257,31 @@ (define (send response) (shift unsused response)) +(define (make-servlet-response response) + (let ((servlet-out-port (open-output-string)) + (servlet-in-port #f) ;; FIXME: no input-port available + (options #f)) ;; FIXME: No access to httpd-options :-( + (if (writer-body? (response-body response)) + (begin + ;; Error-handler is already installed. + ;; Force string-output to resolve all send/... calls. + (display-http-body (response-body response) + servlet-in-port servlet-out-port + options) + ;; Create write-out-response for webserver. + (make-response + (response-code response) + (response-message response) + (response-seconds response) + (response-mime response) + (response-extras response) + (make-writer-body + (lambda (out options) + (display (get-output-string servlet-out-port) out))))) + (make-error-response (status-code bad-gateway) #f + "The servlet returned an invalid response object (no writer-body).")))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; access to session-table (define (session-lookup session-id) diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index 02d852f..90a6db6 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -4,10 +4,9 @@ (define (send-html/suspend html-tree-maker) (send/suspend (lambda (new-url) - (let ((html-page (servlet-XML->HTML #f (html-tree-maker new-url)))) - (make-usual-html-response - (lambda (out options) - (display html-page out))))))) + (make-usual-html-response + (lambda (out options) + (display (servlet-XML->HTML #f (html-tree-maker new-url)) out)))))) (define (send-html/finish html-tree) (do-sending send/finish html-tree))