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

"Raw" version of add form: 

Uses only tools of servlet-handler/servlets.
This commit is contained in:
interp 2002-12-08 18:10:15 +00:00
parent 7f7eb610d8
commit 5879a83b9a
1 changed files with 116 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
scheme/httpd/surflets/web-server/root/surflets/add-raw.scm Normal file
View File

@ -0,0 +1,116 @@
(define-structure servlet servlet-interface
(open httpd-requests ; REQUEST-URL
httpd-responses ; MAKE-RESPONSE
parse-html-forms ; PARSE-HTML-FORM-QUERY
url ; HTTP-URL-SEARCH
srfi-1 ; FILTER
servlet-handler/servlet ; SEND/SUSPEND, SEND/FINISH
scheme-with-scsh)
(begin
(define (extract-bindings key bindings)
(map cdr
(filter (lambda (binding)
(equal? (car binding) key))
bindings)))
(define (extract-single-binding key bindings)
(let ((bindings (extract-bindings key bindings)))
(if (null? bindings)
(error "no binding")
(car bindings))))
(define (make-get-number-page input-text title)
(lambda (new-url)
(let ((HTML-page (format #f "
<HTML>~a
<BODY>~a
<P>
<FORM method=\"GET\" action=\"~a\">
~a
<INPUT type=\"text\" name=\"number\">
<INPUT type=\"submit\">
</FORM>
</P>
<HR>
<P>
<A href=\"/\">Return to main menu.</A><BR>
<A href=\"add-html.scm\">Start new calculation.</A>
</P>
</BODY>
</HTML>"
(if title
(format #f "<TITLE>~a</TITLE>" title)
"")
(if title
(format #f "<H2>~a</H2>" title))
new-url
input-text
)))
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(format out HTML-page))
)))))
(define (make-result-page new-url)
(let ((HTML-page (format #f "
<HTML>
<TITLE>Result</TITLE>
<BODY>
<H1>Result</H1>
<P>
~a
<P>
<HR>
<A href=\"add-html.scm\">New calculation (new session)</A><BR>
<A href=\"javascript:history.back(2)\">New calculation (same session)</A><BR>
<A href=~s>Close this session</A>
</BODY>
</HTML>"
(number->string (+ (get-number1) (get-number2)))
new-url)))
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(format out HTML-page)))
)))
(define (get-number input-text . maybe-title)
(let* ((title (if (pair? maybe-title) (car maybe-title) #f))
(result (send/suspend (make-get-number-page input-text title)))
(bindings (parse-html-form-query
(http-url-search (request-url result))))
(number (string->number
(extract-single-binding "number" bindings))))
(if number
number
(get-number input-text "Please enter a valid number"))))
(define (get-number1)
(get-number "First number:" "Calculation - Step one"))
(define (get-number2)
(get-number "Second number:" "Calculation - Step two"))
(define (main req)
(send/suspend make-result-page)
;; This finishes the session and does a redirect to the root
;; page.
(send/finish
(make-http-error-response http-status/moved-temp req
"/" "/")))
))