+ Change interface of SEND/SUSPEND, SEND/FINISH, SEND:

They expect SURFLET-RESPONSE objects now (not HTTP-RESPONSE).
+  SEND-HTML/SUSPEND, SEND-HTML/FINISH, SEND-HTML respect this.
This commit is contained in:
interp 2003-01-24 15:23:51 +00:00
parent 0ce0da0a1f
commit 6358463b5a
3 changed files with 70 additions and 38 deletions

View File

@ -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

View File

@ -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)
(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)))))
(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 writer-body)."))))
"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)."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

View File

@ -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))))))
(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: