From c48f952cc55de47f3b1737b187b10aea783b6cf3 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Mon, 14 Apr 2003 08:30:27 +0000
Subject: [PATCH] + Add annotated callbacks. Callbacks may now be annotated
 with arbitrary arguments with which the function will be called. See
 surflets/test.scm for a (non-didactic) example.

* The extended callbacks justify an extra structure for callbacks:
surflets/callbacks

- make-callback was moved from surflets/utilities to surflets/callbacks
---
 scheme/httpd/surflets/addresses.scm           |  3 +++
 scheme/httpd/surflets/callbacks.scm           | 25 +++++++++++++++++
 scheme/httpd/surflets/packages.scm            | 18 ++++++++++---
 scheme/httpd/surflets/utilities.scm           |  7 -----
 .../web-server/root/surflets/test.scm         | 27 +++++++++++++++----
 5 files changed, 64 insertions(+), 16 deletions(-)
 create mode 100644 scheme/httpd/surflets/callbacks.scm

diff --git a/scheme/httpd/surflets/addresses.scm b/scheme/httpd/surflets/addresses.scm
index a7b9c41..9b5a8c6 100644
--- a/scheme/httpd/surflets/addresses.scm
+++ b/scheme/httpd/surflets/addresses.scm
@@ -63,3 +63,6 @@
        (else
 	(error "annotated-address: unknown message/bad argument(s)" 
 	       message (address-name address)))))))
+
+      
+
diff --git a/scheme/httpd/surflets/callbacks.scm b/scheme/httpd/surflets/callbacks.scm
new file mode 100644
index 0000000..ada7c8c
--- /dev/null
+++ b/scheme/httpd/surflets/callbacks.scm
@@ -0,0 +1,25 @@
+;; Copyright 2002, 2003 Andreas Bernauer
+
+(define (make-callback function)
+  (call-with-current-continuation
+   (lambda (exit)
+     (let* ((req (send/suspend (lambda (new-url)
+				 (exit new-url)))))
+       (function req)))))
+
+
+(define (make-annotated-callback function)
+  (let* ((annotated-address (make-annotated-address))
+	 (dispatch 
+	  (lambda (req)
+	    (let ((bindings (get-bindings req)))
+	      (cond
+	       ((returned-via annotated-address bindings) =>
+		(lambda (args)
+		  (apply function (cons req args))))
+	       (else
+		(error "annotated-callback: 
+unexpected return values from website"))))))
+	 (callback (make-callback dispatch)))
+    (lambda args
+      (annotated-address callback args))))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index afa98bc..085d8fb 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -307,7 +307,6 @@
 (define-interface surflets/utilities-interface
   (export form-query-list
 	  rev-append
-	  make-callback
 	  generate-unique-name))
 
 ;; Intelligent Addresses
@@ -319,6 +318,10 @@
 ;	  address-add-annotation!
 	  address-annotation))
 
+(define-interface surflets/callbacks-interface
+  (export make-callback
+	  make-annotated-callback))
+
 ;; Returned-via (dispatcher for input-fields and intelligent
 ;; addresses)
 (define-interface surflets/returned-via-interface
@@ -401,7 +404,6 @@
 	threads				;SLEEP
 	uri				;URI-PATH-LIST->PATH
 	with-locks			;WITH-LOCK
-;	inspect-exception		;WITH-INSPECTING-HANDLER
 	)
   (files surflet-handler))
 
@@ -551,8 +553,7 @@
 ;; Some utilities
 (define-structure surflets/utilities surflets/utilities-interface
   (open scheme
-	parse-html-forms
-	(subset surflet-handler/primitives (send/suspend)))
+	parse-html-forms)
   (files utilities))
 
 
@@ -563,8 +564,17 @@
 	(subset uri (escape-uri))
 	define-record-types
 	(subset surflets/utilities (generate-unique-name)))
+)
   (files addresses))
 
+(define-structure surflets/callbacks surflets/callbacks-interface
+  (open scheme
+	srfi-23				;error
+	surflets/addresses
+	(subset surflet-handler/primitives (send/suspend))
+	surflets/bindings
+	surflets/returned-via)
+  (files callbacks))
 
 (define-structure surflets/returned-via surflets/returned-via-interface
   (open scheme
diff --git a/scheme/httpd/surflets/utilities.scm b/scheme/httpd/surflets/utilities.scm
index 755bdbd..41a47fd 100644
--- a/scheme/httpd/surflets/utilities.scm
+++ b/scheme/httpd/surflets/utilities.scm
@@ -20,13 +20,6 @@
 	(rev-app (cdr a) (cons (car a) b))
 	b)))
 
-(define (make-callback function)
-  (call-with-current-continuation
-   (lambda (exit)
-     (let* ((req (send/suspend (lambda (new-url)
-				 (exit new-url)))))
-       (function req)))))
-
 ;; FIXME: consider creating small names
 (define generate-unique-name
   (let ((id 0))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm
index ad452ba..10248a7 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/test.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm
@@ -1,23 +1,40 @@
 (define-structure surflet surflet-interface
   (open scheme-with-scsh
 	surflets
+	surflets/utilities
+	surflets/callbacks
 	httpd-responses)
   (begin
     (define global '())
 
     (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
 
+    (define (result req arg)
+      (send-html
+       `(html (title "Result")
+	      (body (h2 "Result")
+		    (p "Returned via callback with arg" (br)
+		       ,(format #f "~s" arg))))))
+    
     (define (main req)
       (set! global (cons 1 global))
-      (let* ((addr (make-annotated-address))
+      (let* ((an-cb (make-annotated-callback result))
+	     (addr (make-annotated-address))
 	     (req (send-html/suspend
 		  (lambda (new-url)
 		    `(html (body (h1 "This is from SUrflet")
 				 (p "called " ,(length global) " times")
-				 (url ,(addr new-url "ab=ba")) (br)
-				 (url ,(addr new-url "be<ta")) (br)
-				 (url ,(addr new-url)) (br)
-				 (abba)
+				 (p "Choose an annotated address:" (br)
+				    (ul
+				     (li (url ,(addr new-url "ab=ba") "ab=ba"))
+				     (li (url ,(addr new-url "be<ta") "be<ta"))
+				     (li  (url ,(addr new-url) "<nothing>"))))
+				 (p "Or choose an annotated callback" (br)
+				    (ul
+				     (li (url ,(an-cb 13) "13"))
+				     (li (url ,(an-cb '(1 2 3)) "'(1 2 3)"))
+				     (li (url ,(an-cb "hello") "hello"))
+				     (li (url ,(an-cb #f) "#f"))))
 				 (surflet-form
 				  ,new-url
 				  POST