diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 0df1699..393aef2 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -105,10 +105,19 @@ resume-url-session-id resume-url-continuation-id)) +(define-interface surflet-handler/responses-interface + (export make-surflet-response + surflet-response? + surflet-response-status + surflet-response-content-type + surflet-response-headers + surflet-response-data)) + (define-structures ((surflet-handler surflet-handler-interface) (surflet-handler/surflet surflet-handler/surflet-interface) - (surflet-handler/admin surflet-handler/admin-interface)) + (surflet-handler/admin surflet-handler/admin-interface) + (surflet-handler/responses surflet-handler/responses-interface)) (open httpd-responses httpd-requests httpd-errors @@ -184,7 +193,8 @@ (define-structure surflets surflets-interface (open surflet-handler/surflet - httpd-responses + surflet-handler/responses + httpd-responses ; STATUS-CODE httpd-requests ; HTTP-URL:SEARCH url ; REQUEST:URL parse-html-forms diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 3679603..0bcb1eb 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -49,6 +49,28 @@ ;; session lifetime is in seconds (session-lifetime options:session-lifetime set-options:session-lifetime)) +;;; STATUS is the status code, an exact integer. See httpd/response.scm +;;; e.g. (status-code ok) +;;; CONTENT-TYPE is a string, most probably "text/html". +;;; HEADERS is a (maybe empty) list of pairs of (string or symbol); +;;; Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or +;;; '((Cache-Control . "no-cache")) etc. +;;; DATA is either +;;; * a string +;;; * a list of strings +;;; This list maybe extended to vectors later. +(define-record-type surflet-response :surflet-response + (make-surflet-response status content-type headers data) + surflet-response? + (status surflet-response-status) + (content-type surflet-response-content-type) + (headers surflet-response-headers) + (data surflet-response-data)) + +(define (valid-surflet-response-data? data) + (or (string? data) (list? data))) + + ;; Surflet-prefix is unused now. Formerly, it contained the virtual ;; path prefix for the handler. (define (make-default-options surflet-path surflet-prefix) @@ -227,6 +249,7 @@ )))) +;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE. (define (send/suspend response-maker) (shift return (let* ((session-id (instance-session-id)) @@ -246,40 +269,44 @@ session-id continuation-counter continuation-id))) - (make-surflet-response (response-maker new-url)))))) + (make-http-response (response-maker new-url)))))) (make-error-response (status-code not-found) #f - "The URL refers to a surflet, whose session is no longer alive."))))) + "The URL refers to a SUrflet, whose session is no longer alive."))))) (define (send/finish response) (delete-session! (instance-session-id)) - (shift unused (make-surflet-response response))) + (shift unused (make-http-response response))) (define (send response) - (shift unused (make-surflet-response response))) + (shift unused (make-http-response response))) -(define (make-surflet-response response) - (let ((buffer (open-output-string)) - (surflet-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) - surflet-in-port buffer - options) - ;; Create write-out-response for webserver. +(define (make-http-response response) + (cond + ((surflet-response? response) + (let ((data (surflet-response-data response))) + (if (valid-surflet-response-data? data) (make-response - (response-code response) - (response-message response) - (response-seconds response) - (response-mime response) - (response-extras response) - (make-writer-body + (surflet-response-status response) + #f + (time) + (surflet-response-content-type response) + (surflet-response-headers response) + (make-writer-body (lambda (out options) - (display (get-output-string buffer) out))))) - (make-error-response (status-code bad-gateway) #f - "The surflet returned an invalid response object (no writer-body).")))) + (cond + ((string? data) (display data out)) + ((list? data) (for-each (lambda (data) (display data out)) data)) + (else ;; We lose. + (display "Error in SUrflet output.\n" out)) + )))) + (make-error-response (status-code bad-gateway) #f + "The SUrflet returned an invalid response object (no surflet-response).")))) + ((and (response? response) ;; RESPONSE? refers to a HTTP-RESPONSE. + (redirect-body? (response-body response))) + response) + (else + (make-error-response (status-code bad-gateway) #f + "The SUrflet returned an invalid response object (no surflet-response).")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index ac66b58..85cb22f 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -5,8 +5,7 @@ (send/suspend (lambda (new-url) (make-usual-html-response - (lambda (out options) - (display (surflet-XML->HTML #f (html-tree-maker new-url)) out)))))) + (surflet-XML->HTML #f (html-tree-maker new-url)))))) (define (send-html/finish html-tree) (do-sending send/finish html-tree)) @@ -15,19 +14,15 @@ (do-sending send html-tree)) (define (do-sending send html-tree) - (let ((html-page (surflet-XML->HTML #f html-tree))) - (send (make-usual-html-response - (lambda (out options) - (display html-page out)))))) + (send (make-usual-html-response + (surflet-XML->HTML #f html-tree)))) -(define (make-usual-html-response writer-proc) - (make-response +(define (make-usual-html-response html-string) + (make-surflet-response (status-code ok) - #f - (time) "text/html" '(("Cache-Control" . "no-cache")) - (make-writer-body writer-proc))) + html-string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; from cgi-script: