diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 912f03e..863d735 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/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))
diff --git a/scheme/httpd/surflets/simple-surflet-api.scm b/scheme/httpd/surflets/simple-surflet-api.scm
new file mode 100644
index 0000000..902fdb1
--- /dev/null
+++ b/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)))))
diff --git a/scheme/httpd/surflets/web-server/root/htdocs/index.html b/scheme/httpd/surflets/web-server/root/htdocs/index.html
index c780245..ef187fc 100644
--- a/scheme/httpd/surflets/web-server/root/htdocs/index.html
+++ b/scheme/httpd/surflets/web-server/root/htdocs/index.html
@@ -12,6 +12,7 @@
Adding (version 2)
Simple Calculator
Byte Input Widget
+ Simple Servlet
Servlet Administration
This file
@@ -22,7 +23,7 @@
-Last modified: Sat Oct 19 16:48:48 CEST 2002
+Last modified: Sun Nov 3 15:24:22 CET 2002