+ 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:
parent
0ce0da0a1f
commit
6358463b5a
|
@ -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
|
||||
|
|
|
@ -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)))))
|
||||
(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)."))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
@ -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:
|
||||
|
|
Loading…
Reference in New Issue