diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index a027864..70fc7be 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -118,9 +118,10 @@
(surflet-handler/surflets surflet-handler/surflets-interface)
(surflet-handler/admin surflet-handler/admin-interface)
(surflet-handler/responses surflet-handler/responses-interface))
- (open httpd-responses
- httpd-requests
- httpd-errors
+ (open httpd-responses ;replies for httpd
+ httpd-requests ;requests from httpd
+ surflet-requests ;requests for surflets
+ httpd-errors ;errors for httpd
uri ;URI-PATH-LIST->PATH
tables ;HASH-TABLES
define-record-types ;DEFINE-RECORD-TYPE
@@ -193,7 +194,7 @@
(open surflet-handler/surflets
surflet-handler/responses
httpd-responses ; STATUS-CODE
- httpd-requests ; HTTP-URL:SEARCH
+ surflet-requests ; HTTP-URL:SEARCH
url ; REQUEST:URL
parse-html-forms
sxml-to-html ; SXML->HTML
@@ -313,4 +314,23 @@
(open scheme
locks
define-record-types)
- (files thread-safe-counter))
\ No newline at end of file
+ (files thread-safe-counter))
+
+(define-interface surflet-requests-interface
+ (export make-surflet-request
+ surflet-request?
+ surflet-request-request
+ surflet-request-input-port
+ surflet-request-method
+ surflet-request-uri
+ surflet-request-url
+ surflet-request-version
+ surflet-request-headers
+ surflet-request-socket))
+
+(define-structure surflet-requests surflet-requests-interface
+ (open scheme
+ define-record-types
+ httpd-requests)
+ (files surflet-request))
+
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index 8343fe1..cd5c16f 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -46,11 +46,14 @@
(path-string (uri-path->uri path)))
(if (or (string=? request-method "GET")
(string=? request-method "POST"))
- (if (resume-url? path-string)
- (resume-url path-string surflet-path req)
- (launch-new-session path-string surflet-path req))
+ (make-input-response
+ (lambda (input-port)
+ (let ((s-req (make-surflet-request req input-port)))
+ (if (resume-url? path-string)
+ (resume-url path-string surflet-path s-req)
+ (launch-new-session path-string surflet-path s-req)))))
(make-error-response (status-code method-not-allowed) req
- request-method)))
+ request-method)))
(make-error-response (status-code bad-request) req
(format #f "Bad path: ~s" path)))))
@@ -58,13 +61,14 @@
;; Loads and runs a new session of a SUrflet installing the RESET
;; boundary; returns a (HTTP-)RESPONSE. PATH-STRING is the virtual
;; path of the request, SURFLET-PATH is a string pointing to the real
-;; directory of the SUrflets, and REQ the request of the browser.
-(define (launch-new-session path-string surflet-path req)
+;; directory of the SUrflets, and S-REQ the request of the browser.
+(define (launch-new-session path-string surflet-path s-req)
(cond
((file-not-exists? (absolute-file-name path-string surflet-path))
- (make-error-response (status-code not-found) req path-string))
+ (make-error-response (status-code not-found)
+ (surflet-request-request s-req) path-string))
((string=? (file-name-extension path-string) ".scm")
(obtain-lock *session-table-lock*)
@@ -86,7 +90,7 @@
;; Catch conditions from get-surflet-rt-structure.
(lambda (condition decline)
(delete-session! session-id)
- (bad-gateway-error-response req path-string condition))
+ (bad-gateway-error-response s-req path-string condition))
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(fork-thread
(session-surveillance session-id
@@ -99,23 +103,17 @@
(delete-session! session-id)
;; Restore correct continuation with shift.
(shift unused
- (bad-gateway-error-response req path-string condition)))
+ (bad-gateway-error-response s-req path-string condition)))
(with-cwd surflet-path
(with-names-from-rt-structure
surflet surflet-interface
- (main req))))))))) ; Launch serlvet's main procedure.
+ (main s-req))))))))) ; Launch serlvet's main procedure.
(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
- ;; don't have it, so we disable this feature here.
-; (let ((full-file-name (absolute-file-name path-string surflet-path)))
-; (send-file-response full-file-name
-; (file-info full-file-name)
-; req))
- (make-error-response (status-code forbidden) req
- "Can't serve other than Scheme files."
- path-string))
+ (make-error-response (status-code forbidden)
+ (surflet-request-request s-req)
+ "Can't serve other than Scheme files."
+ path-string))
))
@@ -156,12 +154,13 @@
;;; RESUME-URL
;; Resumes a suspended URL and returns a (HTTP-)RESPONSE. PATH-STRING
;; is the virtual path, SURFLET-PATH a string pointing to the real
-;; directory of the SUrflets and REQ the request of the browser.
+;; directory of the SUrflets and S-REQ the request of the browser.
(define resume-url
(let ((bad-request
- (lambda (path-string req)
+ (lambda (path-string s-req)
(make-error-response
- (status-code bad-request) req
+ (status-code bad-request)
+ (surflet-request-request s-req)
(format #f
"
There may be several reasons, why your request for a SUrflet was denied: @@ -181,7 +180,7 @@ (release-lock continuation-table-lock) result))))) - (lambda (path-string surflet-path req) + (lambda (path-string surflet-path s-req) (receive (session-id continuation-id) ;; Searches ids only in file-name. (resume-url-ids (file-name-nondirectory path-string)) @@ -196,9 +195,9 @@ (reset (begin (register-instance! session-id) - (resume req)))) - (bad-request path-string req))) - (bad-request path-string req))) + (resume s-req)))) + (bad-request path-string s-req))) + (bad-request path-string s-req))) )))) @@ -250,12 +249,14 @@ ;;; SEND-ERROR ;; Stops current computation, and leaves current continuation via ;; SHIFT with a (HTTP-)(ERROR-)RESPONSE. STATUS-CODE is a status code -;; from HTTP-RESPONSES, REQ a request (may be #f) and MESSAGES -;; contains further informations (arbitrary types). -(define (send-error status-code req . messages) +;; from HTTP-RESPONSES, S-REQ a surflet-request (may be #f) and +;; MESSAGES contains further informations (arbitrary types). +(define (send-error status-code s-req . messages) (shift unused (apply make-error-response (cons status-code - (cons #f messages))))) + (cons (and (surflet-request? s-req) + (surflet-request-request s-req)) + messages))))) ;;; MAKE-HTTP-RESPONSE ;; Converts a SURFLET-RESPONSE to a (HTTP-)RESPONSE. Returns a @@ -579,9 +580,10 @@ (define (resume-url? resume-url) (regexp-search? *resume-url-regexp* resume-url)) -(define (bad-gateway-error-response req path-string condition) +(define (bad-gateway-error-response s-req path-string condition) (make-error-response - (status-code bad-gateway) req + (status-code bad-gateway) + (surflet-request-request s-req) (format #f "Error in SUrflet ~s." path-string) condition)) diff --git a/scheme/httpd/surflets/surflet-request.scm b/scheme/httpd/surflets/surflet-request.scm new file mode 100644 index 0000000..97ab97e --- /dev/null +++ b/scheme/httpd/surflets/surflet-request.scm @@ -0,0 +1,19 @@ +;; Copyright Andras Bernauer (2003) + +;; somehow `extend' httpd-request +(define-record-type surflet-request :surflet-request + (make-surflet-request request input-port) + surflet-request? + (request surflet-request-request) + (input-port surflet-request-input-port)) + +(define (make-fake-selector request-selector) + (lambda (surflet-request) + (request-selector (surflet-request-request surflet-request)))) + +(define surflet-request-method (make-fake-selector request-method)) +(define surflet-request-uri (make-fake-selector request-uri)) +(define surflet-request-url (make-fake-selector request-url)) +(define surflet-request-version (make-fake-selector request-version)) +(define surflet-request-headers (make-fake-selector request-headers)) +(define surflet-request-socket (make-fake-selector request-socket)) \ No newline at end of file diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index 6e65770..da56ae6 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -41,19 +41,19 @@ (define *POST-bindings-cache* '()) (define *cache-lock* (make-lock)) -(define (get-bindings request) - (let ((request-method (request-method request))) +(define (get-bindings surflet-request) + (let ((request-method (surflet-request-method surflet-request))) (cond ((string=? request-method "GET") - (form-query (http-url-search (request-url request)))) + (form-query (http-url-search (surflet-request-url surflet-request)))) ((string=? request-method "POST") - (or (cached-bindings request) - (let* ((content-length (get-content-length (request-headers request))) - (input-port (socket:inport (request-socket request))) + (or (cached-bindings surflet-request) + (let* ((content-length (get-content-length (surflet-request-headers surflet-request))) + (input-port (surflet-request-input-port surflet-request)) (form-data (read-string content-length input-port))) (let ((form-bindings (form-query form-data))) (obtain-lock *cache-lock*) - (set! *POST-bindings-cache* (cons (cons (make-weak-pointer request) + (set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request) form-bindings) *POST-bindings-cache*)) (release-lock *cache-lock*) @@ -64,17 +64,19 @@ ;; Looking up, if we have cached this request. While going through the ;; list, we remove entries to request objects, that are no longer ;; valid. Expecting a call for an uncached request every now and then, -;; it is guaranteed, that the list is cleaned up every now and then. -(define (cached-bindings request) +;; it is guaranteed, that the list is cleaned up every now and +;; then. The cache is a list of pairs +;;; (surflet-request . computed-binding) +(define (cached-bindings surflet-request) (obtain-lock *cache-lock*) (let ((result (let loop ((cache *POST-bindings-cache*)) (if (null? cache) #f ; no such request cached (let* ((head (car cache)) - (req (weak-pointer-ref (car head)))) - (if req - (if (eq? req request) + (s-req (weak-pointer-ref (car head)))) + (if s-req + (if (eq? s-req surflet-request) (cdar cache) ; request is cached (loop (cdr cache))) ; request isn't cached (begin @@ -271,7 +273,7 @@ (send-html `(html (title "Outdated Data") (body (h1 "Outdated Data") - (p "The page or action you requested relies on outdated data") + (p "The page or action you requested relies on outdated data.") ,(if url `(p "Try to " (URL ,url "reload") diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm index 0d9cecb..04be14e 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm @@ -1,6 +1,6 @@ (define-structure surflet surflet-interface (open surflets - httpd-requests + surflet-requests httpd-responses url scheme-with-scsh) @@ -26,7 +26,7 @@ (p (URL "/" "Return to main menu") (br) (URL "add.scm" "Start new calculation.")))))))) (let* ((bindings (form-query - (http-url-search (request-url result)))) + (http-url-search (surflet-request-url result)))) (number (string->number (extract-single-binding "number" bindings)))) (if number diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm index 933f8c2..653eff7 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm @@ -1,5 +1,5 @@ (define-structure surflet surflet-interface - (open httpd-requests ; REQUEST-URL + (open surflet-requests ; SURFLET-REQUEST-URL httpd-responses ; MAKE-RESPONSE parse-html-forms ; PARSE-HTML-FORM-QUERY url ; HTTP-URL-SEARCH @@ -79,7 +79,7 @@ (let* ((title (if (pair? maybe-title) (car maybe-title) #f)) (result (send/suspend (make-get-number-page input-text title))) (bindings (parse-html-form-query - (http-url-search (request-url result)))) + (http-url-search (surflet-request-url result)))) (number (string->number (extract-single-binding "number" bindings)))) (if number diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm b/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm index 35049af..2bdd4ac 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm @@ -1,6 +1,6 @@ (define-structure surflet surflet-interface (open surflets - httpd-requests + surflet-requests url handle-fatal-error let-opt @@ -26,7 +26,8 @@ (URL "add2.scm" "Start new calculation.")))))))) (if result (or (input-field-value number-input-field - (form-query (http-url-search (request-url result)))) + (form-query (http-url-search + (surflet-request-url result)))) (get-number title "Please enter a valid number.")) (get-number title "Please enter a number.")))) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm index c0c42ba..7635c34 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm @@ -3,7 +3,7 @@ surflets surflet-handler/admin httpd-responses - httpd-requests + surflet-requests url handle-fatal-error let-opt @@ -152,7 +152,7 @@ (current-sessions (sort-list! (get-sessions) session-surflet-name))) (real-sessions current-sessions update-text (resume-url-session-id - (last (http-url-path (request-url req))))))) + (last (http-url-path (surflet-request-url req))))))) (define (real-sessions current-sessions update-text this-session-id) (let ((outdated? (make-outdater)) @@ -258,7 +258,7 @@ (session-id (car session-pair)) (session-entry (cdr session-pair)) (this-continuation-id (resume-url-continuation-id - (last (http-url-path (request-url req))))) + (last (http-url-path (surflet-request-url req))))) (update-text (:optional maybe-update-text ""))) (let* ((current-continuations (sort-list! (get-continuations session-id) diff --git a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm index be70303..db51a37 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm @@ -1,6 +1,6 @@ (define-structure surflet surflet-interface (open surflets - httpd-requests + surflet-requests handle-fatal-error url scheme-with-scsh) @@ -55,7 +55,7 @@ ,(make-submit-button)) (hr) (p (URL "/" "Return to main menu."))))))) - (bindings (form-query (http-url-search (request-url req))))) + (bindings (form-query (http-url-search (surflet-request-url req))))) (input-field-value byte-input-fields bindings))) (define (main req) diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm index 8f67fe2..bba7dc5 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm @@ -1,6 +1,6 @@ (define-structure surflet surflet-interface (open surflets - httpd-requests + surflet-requests handle-fatal-error let-opt scheme-with-scsh) diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm index fdaa9dc..7679e67 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm @@ -1,6 +1,6 @@ (define-structure surflet surflet-interface (open surflets - httpd-requests + surflet-requests handle-fatal-error let-opt scheme-with-scsh) diff --git a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm index e04c9c0..d40cef0 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm @@ -7,7 +7,7 @@ (subset srfi-13 (string-downcase string-join)) (subset srfi-1 (find filter-map split-at remove)) sunet-utilities - httpd-requests) + surflet-requests) (begin ;;; Spaceship components @@ -462,7 +462,8 @@ spaceships of class " ,class ":") (p "Thank you for your ordering.") (p "Your order has been registered. " "We will contact you (" - ,(host-name-or-ip (socket-remote-address (request-socket req))) + ,(host-name-or-ip (socket-remote-address + (surflet-request-socket req))) ") as soon as the ship is built.") (p "This will take about " ,months " months.") ,(return-links first-page-return-link main-return-link))))