From 5879a83b9a43a7776bb9a2743f3511528eba12fd Mon Sep 17 00:00:00 2001 From: interp Date: Sun, 8 Dec 2002 18:10:15 +0000 Subject: [PATCH] "Raw" version of add form: Uses only tools of servlet-handler/servlets. --- .../web-server/root/surflets/add-raw.scm | 116 ++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 scheme/httpd/surflets/web-server/root/surflets/add-raw.scm diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm new file mode 100644 index 0000000..2843a88 --- /dev/null +++ b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm @@ -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 " +~a +~a +

+

+ ~a + + +
+

+
+

+ Return to main menu.
+ Start new calculation. +

+ +" + (if title + (format #f "~a" title) + "") + (if title + (format #f "

~a

" 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 " + +Result + +

Result

+

+ ~a +

+

+New calculation (new session)
+New calculation (same session)
+Close this session + +" + (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 + "/" "/"))) + + )) + \ No newline at end of file