Add MAKE-ANNOTATED-ADDRESS that creates string-annotated return-addresses

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

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