From 98f0da38c6714c1f8bad03e6a73f58a48a169637 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Fri, 28 Feb 2003 08:22:29 +0000
Subject: [PATCH] Add MAKE-ANNOTATED-ADDRESS that creates string-annotated
 return-addresses

---
 scheme/httpd/surflets/packages.scm |  2 ++
 scheme/httpd/surflets/surflets.scm | 53 +++++++++++++++++++++++-------
 2 files changed, 44 insertions(+), 11 deletions(-)

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 2c8232c..989af68 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -185,6 +185,7 @@
 	  input-field-binding
 
 	  make-address
+	  make-annotated-address
 	  returned-via?
 	  make-callback
 
@@ -197,6 +198,7 @@
 	httpd-responses			; STATUS-CODE
 	surflet-requests		; HTTP-URL:SEARCH
 	url				; REQUEST:URL
+	(subset uri (escape-uri unescape-uri))
 	parse-html-forms
 	sxml-to-html			; SXML->HTML
 	srfi-1				; FILTER
diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
index 230a4fe..76fa7b7 100644
--- a/scheme/httpd/surflets/surflets.scm
+++ b/scheme/httpd/surflets/surflets.scm
@@ -246,8 +246,6 @@
        (function req)))))
 
 
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; outdater
 
@@ -633,22 +631,55 @@
 ;;     (lambda (new-url)
 ;;       ...
 ;;       (URL (address new-url) "Click here to get more")...)                
+
+(define-record-type address :address
+  (really-make-address name annotated?)
+  (name address-name)
+  (annotated? address-annotated?))
+
 (define (make-address)
-  (let ((name (generate-unique-name "return")))
+  (let ((address (really-make-address
+		  (generate-unique-name "return") #f)))
     (lambda (message)
       (cond
        ((string? message)
-	(string-append message "?" name "="))
-       ((eq? message 'name)
-	name)
-       (else				;maybe we want more later...
-	(error "unknown message" message name))))))
-	
+	(string-append message "?" (address-name address) "="))
+       ((eq? message 'address)
+	address)
+       (else
+	(error "address: unknown message/bad argument" 
+	       message (address-name address)))))))
+
+(define (make-annotated-address)
+  (let ((address (really-make-address 
+		  (generate-unique-name "return")
+		  #t)))
+    (lambda (message . annotation)
+      (cond
+       ((and (string? message)
+	     (<= (length annotation) 1))
+	(let ((escaped-annotation 
+	       (if (null? annotation)
+		   ""
+		   (escape-uri (car annotation)))))
+	  (string-append message "?" (address-name address)
+			 "=" escaped-annotation)))
+       ((eq? message 'address)
+	address)
+       (else
+	(error "annotated-address: unknown message/bad argument(s)" 
+	       message (address-name address)))))))
 
 (define (returned-via? return-object bindings)
-  (format #t "returned-via? ~a~%" return-object)
   (if (input-field? return-object)
       (input-field-binding return-object bindings)
       ;; We assume we have a return-address-object instead.
-      (assoc (return-object 'name) bindings)))
+      (let ((address (return-object 'address)))
+	(cond 
+	 ((assoc (address-name address) bindings) =>
+	  (lambda (pair)
+	    (if (address-annotated? address)
+		(unescape-uri (cdr pair))
+		#t)))
+	 (else #f)))))