+ REQUEST object extended for SUrflets by INPUT-PORT

+ SURFLET-REQUESTs used in SUrflets
+ Use MAKE-INPUT-RESPONSE to generate SUrflet responses

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
@@ -314,3 +315,22 @@
 	locks
 	define-record-types)
   (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))
+

scheme/httpd/surflets/surflet-handler.scm

@@ -46,9 +46,12 @@
 	      (path-string (uri-path->uri path)))
 	  (if (or (string=? request-method "GET")
 		  (string=? request-method "POST"))
+	      (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 req)
-		  (launch-new-session path-string surflet-path req))
+		       (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)))
 	(make-error-response (status-code bad-request) req 
@@ -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,21 +103,15 @@
 	     (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
+    (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 
 		    "<br>
 <p>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))
 

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

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") 

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

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

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."))))
 

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)

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)

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)

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)

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