Simple servlet api adopted from PLT. Example included

scheme/httpd/surflets/packages.scm

@@ -256,3 +256,27 @@
 	scheme)
   (files profile))
 
+(define-interface simple-servlet-api-interface
+  (export single-query
+	  queries
+	  form-query
+	  inform
+	  final-page
+	  make-password
+	  make-number
+	  make-boolean
+	  make-radio
+	  make-yes-no
+	  extract/single
+	  extract))
+
+(define-structure simple-servlet-api simple-servlet-api-interface
+  (open scsh
+	scheme
+	define-record-types
+	let-opt
+	servlets
+	(subset srfi-1 (zip filter))
+	handle-fatal-error
+	)
+  (files simple-servlet-api))

scheme/httpd/surflets/simple-surflet-api.scm

@@ -0,0 +1,177 @@
+;;; Simple Servlet API, shamelessly adapted / copied from PLT.
+;;; Copyright 2002, Andreas Bernauer
+
+;; Send a query, suspend the current program, and produce for an
+;; answer that matches query.
+(define (single-query query)
+  (car (get-results (list query) "Web Query")))
+
+(define (queries queries)
+  (get-results queries "Web Query"))
+
+(define (form-query assoc-query-list)
+  (zip (map car assoc-query-list)
+       (get-results (map cadr assoc-query-list) "Web Query")))
+
+(define (get-results queries title . maybe-update-text)
+  (let* ((queries (map transform-string-to-query queries))
+	 (update-text (:optional maybe-update-text #f))
+	 (req (send-html/suspend
+	       (lambda (new-url)
+		 `(html 
+		   (title ,title)
+		   (body (@ (bgcolor "white"))
+			 (h3 ,(if update-text `(font (@ (color "red")) ,update-text) title))
+			 (servlet-form ,new-url POST
+				       (table ,@(map (lambda (query)
+						       (ask query 'html-table-row))
+						     queries))
+				       ,(make-submit-button)))))))
+	 (bindings (get-bindings req)))
+    (call-with-current-continuation
+     (lambda (exit)
+       (map (lambda (query)
+	      (with-fatal-error-handler
+	       (lambda (c m) 
+		 (exit
+		  (get-results queries title 
+			       (ask query 'bad-input-text))))
+	       (ask query 'value bindings)))
+       queries)))))
+
+
+;; Post some information on a Web page, wait for continue signal.
+(define (inform title . text)
+  (send-html/suspend 
+   (lambda (url)
+     `(html 
+       (title ,title)
+       (body (@ (bgcolor "white"))
+	     (h3 ,title)
+	     (br)
+	     (p ,@text)
+	     (br)
+	     (URL ,url "Continue"))))))
+
+;; Post some information on a Web page, shut down the servlet and all
+;; its continuations.
+(define (final-page title . text)
+  (send-html/finish
+   `(html 
+     (title ,title)
+     (body (@ (bgcolor "white"))
+	   (h3 ,title)
+	   (br)
+	   (p ,@text)))))
+
+
+;(define-record-type query :query
+;  (make-query type text input-field insist)
+;  query?
+;  (type query-type)
+;  (text query-text)
+;  (input-field query-input-field)
+;  (insist query-insist))
+
+(define (standard-query text input-field insist)
+  (lambda (message)
+    (case message
+      ((html-table-row)
+       (lambda (self)
+	 `(tr (td ,text) (td ,input-field))))
+      ((value)
+       (lambda (self bindings)
+	 (input-field-value input-field bindings)))
+      ((bad-input-text)
+       (lambda (self)
+	 (format #f "~a to the question: ~a" insist text)))
+      (else (no-method message)))))
+
+(define (make-text text)
+  (standard-query text (make-text-input-field) "No bad input possible"))
+
+(define (make-password text)
+  (standard-query text (make-password-input-field) "No bad input possible"))
+
+(define (make-number text) 
+  (standard-query text (make-number-input-field) "Please respond with a valid number"))
+
+(define (make-boolean text)
+  (let* ((input-field (make-checkbox-input-field))
+	 (standard (standard-query text input-field "No bad input possible")))
+    (lambda (message)
+      (case message
+       ((value)
+	(lambda (self bindings)
+	  (if (input-field-binding input-field bindings) #t #f)))
+       (else
+	(get-method standard message))))))
+
+(define (make-radio text choices)
+  (let* ((radios (make-radio-input-fields choices))
+	 (standard (standard-query text (car radios) "Please respond")))
+    (lambda (message)
+      (case message
+	((html-table-row)
+	 (lambda (self)
+	   `(tr (td ,text)
+		(td (table (tr
+			    ,@(map (lambda (radio choice)
+				     `((td ,radio) (td ,choice)))
+				   radios
+				   choices)))))))
+	(else
+	 (get-method standard message))))))
+
+(define (make-yes-no text yes-text no-text)
+  (let ((radio (make-radio text (list yes-text no-text))))
+    (lambda (message)
+      (case message
+	((bad-input-text)
+	 (format #f "Please respond with ~s or ~s" 
+		 yes-text no-text))
+	(else
+	 (get-method radio message))))))
+	 
+
+(define (transform-string-to-query query)
+  (if (string? query)
+      (make-text query)
+      query))
+
+(define (extract/single symbol table)
+  (let ((entries (extract symbol table)))
+    (if (= 1 (length entries))
+	(car entries)
+	(error "Symbol occurs zero times or more than once." symbol table))))
+
+(define (extract symbol table)
+  (map cadr
+       (filter (lambda (entry) (equal? symbol (car entry)))
+	       table)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; OOP
+;;; from Mike Sperber
+;; Objects are procedures returning methods
+
+(define get-method
+  (lambda (object message)
+    (object message)))
+
+;; The return value of NO-METHOD must be distinguishable from methods.
+
+(define-record-type no-method :no-method
+  (no-method name)
+  no-method?
+  (name no-method-name))
+
+(define (method? x)
+  (not (no-method? x)))
+
+;; ASK gets a method and calls it
+(define (ask object message . args)
+  (let ((method (get-method object message)))
+    (if (no-method? method)
+	(error "No method" message (no-method-name method))
+	(apply method (cons object args)))))

scheme/httpd/surflets/web-server/root/htdocs/index.html

@@ -12,6 +12,7 @@
       <li><a href="servlet/add2.scm">Adding (version 2)</a></li>
       <li><a href="servlet/calculate.scm">Simple Calculator</a></li>
       <li><a href="servlet/byte-input.scm">Byte Input Widget</a></li>
+      <li><a href="servlet/simple-servlet.scm">Simple Servlet</a></li>
 <!--       <li><a href=/servlet/test.scm>A test servlet</a></li> -->
       <li><a href="servlet/admin.scm">Servlet Administration</a></li>
       <li><a href=index.html>This file</a></li>
@@ -22,7 +23,7 @@
     <hr>
     <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
     <!-- hhmts start -->
-Last modified: Sat Oct 19 16:48:48 CEST 2002
+Last modified: Sun Nov  3 15:24:22 CET 2002
 <!-- hhmts end -->
   </body>
 </html>

scheme/httpd/surflets/web-server/root/surflets/simple-servlet.scm

@@ -0,0 +1,40 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	simple-servlet-api)
+  (begin
+    
+    (define (main req)
+      (let* ((answers 
+	      (form-query
+	       (list 
+		(list 'name "Full Name")
+		(list 'pwd (make-password "Password"))
+		(list 're-pwd (make-password "Retype password"))
+		(list 'yob (make-number "Year of birth"))
+		(list 'mail? (make-boolean "Subscribe to mailing list"))
+		(list 'payment (make-yes-no "Pay per" "bill" "card"))
+		(list 'date-of-bill 
+		      (make-radio "Pay at" 
+				  (list "first" "middle" "end of month."))))))
+	     )
+	(if (string=? (extract/single 'pwd answers)
+		      (extract/single 're-pwd answers))
+	    (begin
+	      (inform (format #f "Hi ~a, you're password is ~s, you were born in ~a, you ~a to the mailing list and you pay per ~a at ~a of month. Click continue to perform recording."
+			      (extract/single 'name answers)
+			      (extract/single 'pwd answers)
+			      (extract/single 'yob answers)
+			      (if (extract/single 'mail? answers)
+				  "have subscribed"
+				  "did not subscribe")
+			      (extract/single 'payment answers)
+			      (car ((infix-splitter) 
+				    (extract/single 'date-of-bill answers)))))
+	      (final-page "Data recorded."))
+	    (begin
+	      (inform (format #f "Hi ~a, you've misspelled your password. Go back and retype it."))
+	      (final-page "Your registration has been canceled.")))))
+
+))
+