cache GET-BINDINGS-RESULTS' results of POST requests with weak-pointers

scheme/httpd/surflets/surflets.scm

@@ -33,22 +33,60 @@
 ;;; Return the form data as an alist of decoded strings.
 ;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
 ;;;     (("button" . "on") ("reply" . "Oh, yes"))
-;;; This only works for GET and POST methods.
+;;; This works only for GET and POST methods.
 
 (define form-query parse-html-form-query)
+
+;; Bindings of POST requests can be read only once, since they are
+;; read from an input port. So we have to cache them, for the case of
+;; a later GET-BINDINGS call on the same POST request. The request are
+;; referenced by a weak pointer.
+(define *POST-bindings-cache* '())
+(define *cache-lock* (make-lock))
+
 (define (get-bindings request)
   (let ((request-method (request:method request)))
     (cond
      ((string=? request-method "GET")
       (form-query (http-url:search (request:url request))))
      ((string=? request-method "POST")
-      (let* ((content-length (get-content-length (request:headers request)))
-	     (input-port (socket:inport (request:socket request)))
-	     (form-data (read-string content-length input-port)))
-	(form-query form-data)))
+      (or (cached-bindings request)
+	  (let* ((content-length (get-content-length (request:headers request)))
+		 (input-port (socket:inport (request:socket 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)
+						      form-bindings)
+						*POST-bindings-cache*))
+	      (release-lock *cache-lock*)
+	      form-bindings))))
      (else
       (error "unsupported request type")))))
 
+;; 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)
+  (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)
+			 (cdar cache)	; request is cached
+			 (loop (cdr cache))) ; request isn't cached
+		     (begin
+		       ;; request object is gone ==> remove it from list
+		       (set! cache (cdr cache))
+		       (loop cache))))))))
+    (release-lock *cache-lock*)
+    result))
+   
 ;; Will be needed when we handle POST requests.
 (define (get-content-length headers)
   (cond ((get-header headers 'content-length) =>