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