2003-01-19 11:57:27 -05:00
|
|
|
(define-structure surflet surflet-interface
|
2003-03-10 04:23:41 -05:00
|
|
|
(open surflet-requests ; SURFLET-REQUEST-url
|
2002-12-08 13:10:15 -05:00
|
|
|
httpd-responses ; MAKE-RESPONSE
|
|
|
|
|
parse-html-forms ; PARSE-HTML-FORM-QUERY
|
2003-03-10 04:23:41 -05:00
|
|
|
url ; HTTP-url-SEARCH
|
2002-12-08 13:10:15 -05:00
|
|
|
srfi-1 ; FILTER
|
2003-01-24 11:05:39 -05:00
|
|
|
surflet-handler/surflets ; SEND/SUSPEND, SEND/FINISH
|
2003-03-13 06:36:49 -05:00
|
|
|
surflet-handler/primitives ; MAKE-SURFLET-RESPONSE
|
2002-12-08 13:10:15 -05:00
|
|
|
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)
|
2003-01-24 11:05:39 -05:00
|
|
|
(make-surflet-response
|
2003-01-18 12:18:19 -05:00
|
|
|
(status-code ok)
|
|
|
|
|
"text/html"
|
|
|
|
|
'()
|
2003-01-24 11:05:39 -05:00
|
|
|
(format #f "
|
2002-12-08 13:10:15 -05:00
|
|
|
<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>
|
2003-04-13 16:27:03 -04:00
|
|
|
<A href=\"add-raw.scm\">Start new calculation.</A>
|
2002-12-08 13:10:15 -05:00
|
|
|
</P>
|
|
|
|
|
</BODY>
|
|
|
|
|
</HTML>"
|
2003-01-24 11:05:39 -05:00
|
|
|
(if title
|
|
|
|
|
(format #f "<TITLE>~a</TITLE>" title)
|
|
|
|
|
"")
|
|
|
|
|
(if title
|
|
|
|
|
(format #f "<H2>~a</H2>" title))
|
|
|
|
|
new-url
|
|
|
|
|
input-text
|
|
|
|
|
))))
|
2002-12-08 13:10:15 -05:00
|
|
|
|
|
|
|
|
(define (make-result-page new-url)
|
2003-01-24 11:05:39 -05:00
|
|
|
(make-surflet-response
|
2003-01-18 12:18:19 -05:00
|
|
|
(status-code ok)
|
|
|
|
|
"text/html"
|
|
|
|
|
'()
|
2003-01-24 11:05:39 -05:00
|
|
|
(format #f "
|
2002-12-08 13:10:15 -05:00
|
|
|
<HTML>
|
|
|
|
|
<TITLE>Result</TITLE>
|
|
|
|
|
<BODY>
|
2003-01-16 07:09:49 -05:00
|
|
|
<H2>Result</H2>
|
2002-12-08 13:10:15 -05:00
|
|
|
<P>
|
|
|
|
|
~a
|
|
|
|
|
<P>
|
|
|
|
|
<HR>
|
2003-04-13 16:27:03 -04:00
|
|
|
<A href=\"add-raw.scm\">New calculation (new session)</A><BR>
|
2003-01-19 12:26:56 -05:00
|
|
|
<A href=\"javascript:history.go(-2)\">New calculation (same session)</A><BR>
|
2002-12-08 13:10:15 -05:00
|
|
|
<A href=~s>Close this session</A>
|
|
|
|
|
</BODY>
|
|
|
|
|
</HTML>"
|
2003-01-24 11:05:39 -05:00
|
|
|
(number->string (+ (get-number1) (get-number2)))
|
|
|
|
|
new-url)))
|
2002-12-08 13:10:15 -05:00
|
|
|
|
|
|
|
|
(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
|
2003-02-17 05:09:24 -05:00
|
|
|
(http-url-search (surflet-request-url result))))
|
2002-12-08 13:10:15 -05:00
|
|
|
(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.
|
2003-01-24 11:05:39 -05:00
|
|
|
(send-error (status-code moved-temp) #f "/" "/"))
|
2002-12-08 13:10:15 -05:00
|
|
|
|
|
|
|
|
))
|
|
|
|
|
|
