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

;;; 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 . maybe-insist)
  (let* ((insist (:optional maybe-insist ""))
	 (radios (make-radio-input-fields choices))
	 (standard (standard-query text (car radios) 
				   (string-append "Please respond" insist))))
    (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)
  (make-radio text 
	      (list yes-text no-text)
	      (format #f " with ~s or ~s" yes-text no-text)))

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