diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 1b87d95..3a4fbc7 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -279,7 +279,7 @@ define-record-types let-opt servlets - (subset srfi-1 (zip filter)) + (subset srfi-1 (zip filter find make-list)) handle-fatal-error ) (files simple-servlet-api)) diff --git a/scheme/httpd/surflets/simple-surflet-api.scm b/scheme/httpd/surflets/simple-surflet-api.scm index 60da9fe..22cdf6b 100644 --- a/scheme/httpd/surflets/simple-surflet-api.scm +++ b/scheme/httpd/surflets/simple-surflet-api.scm @@ -13,32 +13,41 @@ (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))))) +(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) @@ -77,7 +86,10 @@ (lambda (message) (case message ((html-table-row) - (lambda (self) + (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) @@ -115,7 +127,8 @@ (lambda (message) (case message ((html-table-row) - (lambda (self) + (lambda (self default) + ;; See note above for default. `(tr (td ,text) (td (table (tr ,@(map (lambda (radio choice)