scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Simple servlet api adopted from PLT. Example included

This commit is contained in:
interp 2002-11-03 17:43:58 +00:00
parent 9815824581
commit d026036bf3
4 changed files with 243 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
scheme/httpd/surflets/packages.scm
View File

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

177
scheme/httpd/surflets/simple-surflet-api.scm Normal file
View File

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

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

@ -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>

40
scheme/httpd/surflets/web-server/root/surflets/simple-servlet.scm Normal file
View File

@ -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.")))))
))