Add MAKE-ANNOTATED-ADDRESS that creates string-annotated return-addresses
This commit is contained in:
parent
b2884b22e2
commit
98f0da38c6
|
@ -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
|
||||
|
|
|
@ -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)))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue