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

187 lines
5.3 KiB
Scheme
Raw Normal View History

;;; 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+defaults)
(let-optionals maybe-update-text+defaults
((update-text #f)
(defaults (make-list (length queries) #f)))
(let* ((queries (map transform-string-to-query queries))
(req (send-html/suspend
(lambda (new-url)
(generate-simple-servlet-page new-url update-text
title
queries defaults))))
(bindings (get-bindings req))
(queries+values (map (lambda (query)
(cons query (ask query 'value bindings)))
queries))
(bad-query+value (find (lambda (query+value)
(not (cdr query+value)))
queries+values)))
(if bad-query+value
(get-results queries title
(ask (car bad-query+value) 'bad-input-text)
(map cdr queries+values))
(map cdr queries+values)))))
(define (generate-simple-servlet-page new-url update-text title queries defaults)
`(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 default)
(ask query 'html-table-row default))
queries defaults))
,(make-submit-button)))))
;; 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 default)
;; DEFAULT is ignored currently. There is a problem with
;; adding the default-value to an already generated
;; input-field.
`(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))))))
2002-11-05 17:20:59 -05:00
(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 default)
;; See note above for default.
`(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)
2002-11-05 17:20:59 -05:00
(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)))))