From f237af61400c5f0afe7f7a0f0cde300dc295a827 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 17 Jul 2008 02:13:46 +0000 Subject: [PATCH] Getting servlet2 back to working shape. Changes include: Wrapped the major servlet2 functions so they talk to a running server thread under an on-web context. Bumped timeout to +inf. When starting server, checks to see if the port is available. If not, tries to choose 8001, 8002, ... up to 8032 before giving up. svn: r10806 --- collects/htdp/servlet2.ss | 939 ++++++++++++++++++++++---------------- 1 file changed, 543 insertions(+), 396 deletions(-) diff --git a/collects/htdp/servlet2.ss b/collects/htdp/servlet2.ss index ba494d2096..b454aa1591 100644 --- a/collects/htdp/servlet2.ss +++ b/collects/htdp/servlet2.ss @@ -1,39 +1,49 @@ -(module servlet2 mzscheme - #| TODO ----------------------------------------------------------------------- +(module servlet2 scheme/base + #| TODO ----------------------------------------------------------------------- buttons: multiple points of returns: continuation functions - |# - (require web-server/servlet-env - htdp/error - mzlib/list - mzlib/etc) - (provide (all-from web-server/servlet-env) - - single-query ; FormElement -> Answer - - queries ; (listof FormElement) -> (listof Answer) - echo-answers ; (listof Answers) -> true - - form-query ; Form -> Response - echo-response ; Response -> true - extract/single ; Symbol Response -> Answer - extract ; Symbol Response -> (listof Answer) - - inform ; String String *-> true - inform/html ; (listof Xexpr) -> true - final-page ; String String *-> true - - ; Structures -------------------------------------------------------------- - make-password - (rename make-numeric make-number) - make-yes-no - (rename make-check make-boolean) - make-radio - ; make-button - - form? - form-element? - - #| Data Definitions -------------------------------------------------------- + |# + (require (prefix-in servlet: web-server/servlet-env) + htdp/error + scheme/tcp + scheme/bool + scheme/list + scheme/match) + + (require (for-syntax scheme/base)) + + (provide single-query ; FormElement -> Answer + + queries ; (listof FormElement) -> (listof Answer) + echo-answers ; (listof Answers) -> true + + form-query ; Form -> Response + echo-response ; Response -> true + extract/single ; Symbol Response -> Answer + extract ; Symbol Response -> (listof Answer) + + inform ; String String *-> true + inform/html ; (listof Xexpr) -> true + final-page ; String String *-> true + + ; Structures -------------------------------------------------------------- + make-password + (rename-out (make-numeric make-number) + (make-check make-boolean)) + make-yes-no + make-radio + ; make-button + + form? + form-element? + + ;; Advanced API from servlet-env: + send/suspend + send/finish + (rename-out (servlet:extract-binding/single extract-binding/single) + (servlet:extract-bindings extract-bindings)) + + + #| Data Definitions -------------------------------------------------------- FormElement = (union String (make-password String) @@ -49,20 +59,20 @@ Answer = (union String Number Boolean) Response = (listof (list Symbol Answer)) |# - ) - - ; ;; - ;;;;; ; ;;; ;;;;; ; - ; ; ; ; ; ; ;; ; - ; ; ;;;; ;;;;; ;;;; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; - ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;; ; ;;;; ;;; ; ;;;; ; ; ; ; ; ; ; ; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;; ; ; ; ; ; - ;;;;; ;;; ; ;;; ;;; ; ;;; ; ;;;; ;;;; ;;; ; ;;;;; ;;; ; ;;; - - - #| Documentation ------------------------------------------------------------ + ) + + ; ;; + ;;;;; ; ;;; ;;;;; ; + ; ; ; ; ; ; ;; ; + ; ; ;;;; ;;;;; ;;;; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; + ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;; ; ;;;; ;;; ; ;;;; ; ; ; ; ; ; ; ; ;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;; ; ; ; ; ; + ;;;;; ;;; ; ;;; ;;; ; ;;; ; ;;;; ;;;; ;;; ; ;;;;; ;;; ; ;;; + + + #| Documentation ------------------------------------------------------------ (define-checked (name pred_1? ... pred_n?)) re-defines the constructor make-name so that it makes sure that its n arguments satisfy pred_1? ... pred_n? @@ -70,355 +80,492 @@ Note: to maintain the invariant, also modify the mutators to check their arguments |# - (define-syntax (define-checked stx) - (syntax-case stx () - [(_ (name pred? ...)) - (let ([make-variable - ; String SyntaxObject -> SyntaxObject - (lambda (x y) - (datum->syntax-object - stx - (string->symbol - (format "~a-~a" x (syntax-object->datum y)))))]) - (with-syntax ([make-name (make-variable "make" (syntax name))] - [(x ...) (generate-temporaries (syntax (pred? ...)))]) - (syntax - (set! make-name - (let ([make-name make-name]) - (lambda (x ...) - (check-arg 'make-name (pred? x) pred? "an" x) - ... - (make-name x ...)))))))])) - ; _ -> true - (define (true? x) #t) - - ;; Structure Definitions ---------------------------------------------------- - (define-struct fe (question)) - - (define-struct (password fe)()) - (define-struct (numeric fe) ()) - (define-struct (check fe) ()) - (define-struct (yes-no fe) (positive negative)) - (define-struct (radio fe) (labels)) - - (define-checked (password string?)) - (define-checked (numeric string?)) - (define-checked (check string?)) - (define (list-of-strings? l) - (and (list? l) (andmap string? l))) - (define-checked (radio string? list-of-strings?)) - (define-checked (yes-no string? true? true?)) - - ; todo - (define-struct (button fe) ()) - - - ; _ -> (union true String) - (define (form? x) - (cond - [(not (list? x)) (format "list expected, given ~e" x)] - [(find-non list? x) - => - (lambda (non-list) - (format "list of lists expected, give list with ~e" non-list))] - [(find-non - (lambda (x) - (and (list? x) - (= (length x) 2) - (symbol? (car x)) - (form-element? (cadr x)))) - x) - => - (lambda (non-tagged-fe) - (format "list of (list Symbol FormElement) expected, given ~s" non-tagged-fe))] - [else true])) - - ; _ -> Boolean - (define (form-element? x) - (cond - [(string? x) #t] - [(fe? x) (and - (string? (fe-question x)) - (cond - [(radio? x) (and (non-empty-list? (radio-labels x)) - (andmap string? (radio-labels x)))] - [(yes-no? x) (and (string? (yes-no-positive x)) - (string? (yes-no-negative x)))] - [else #t]))] - [else #f])) - - ; _ -> Boolean - (define (non-empty-list? x) - (and (cons? x) (list? x))) - - ; - ;; ;; - ;; ;; - ;; ;; ;;;; ;;; ; ;;; ;;; - ; ; ; ; ; ;; ; ; ; - ; ; ; ;;;; ; ; ; ;;; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; - ;;; ;;; ;;; ; ;;;;; ;;; ;; ;;; - - - ; posing questions ---------------------------------------------------------- - - ; FormElement -> Answer - ; to pose one question, receive one answer - (define (single-query fe) - (check-arg 'single-query (form-element? fe) "form element" "first" fe) - (car (queries (list fe)))) - - ; (listof FormElement) -> (listof Answer) - ; to ask N questions and to get N answers - ; assert: (lambda (result) (= (length fes) (length result))) - (define (queries fes) - (check-arg 'queries (and (list? fes) (andmap form-element? fes)) - "list of form elements" "first" fes) - (conduct-query "Web Query" (map list (make-keys fes) fes))) - - ; Form -> Bindings - ; to ask N questions with tags, receive N answers - ; assert: (lambda (result) (set-equal? (map car aloss) (map car result))) - (define (form-query f) - (check-list-list 'form-query (form? f) "form" f) - (map list (map first f) - (conduct-query "Web Query" (map list (make-keys f) (map second f))))) - - - ; extracting values from forms ---------------------------------------------- - - ; extract : Symbol Response -> (listof Answer) - ; extract all answers associated with a tag - (define (extract tag r) - (map second (filter (lambda (a) (eq? (first a) tag)) r))) - - ; extract/single : Symbol Response -> Answer - (define (extract/single tag r) - (let ([all (extract tag r)]) - (if (and (pair? all) (null? (rest all))) ; (= (length all) 1) - (first all) - (cond - [(null? all) - (error 'extract/single "~e contains no tag ~e" r tag)] - [else - (error 'extract/single "~e contains more than one tag ~e" r tag)])))) - - ; echoing responses --------------------------------------------------------- - - ; Response -> true - ; to display a response on a web page - (define (echo-response form) - (make-echo-page - (map (lambda (tag answer) - `(tr (td ,(symbol->string tag)) - (td ,(answer->string answer)))) - (map first form) - (map second form)))) - - ; (listof Answer) -> true - ; to display a list of answers on a web page - (define (echo-answers form) - (make-echo-page - (map (lambda (answer) `(tr (td ,(answer->string answer)))) form))) - - ; displaying information ---------------------------------------------------- - - ; String String *-> true - ; to deliver an intermediate message and a link to continue - (define (inform title . paragraph) - (check-arg 'inform (string? title) "string" "first" title) - (check-arg 'inform (andmap string? paragraph) - "list of strings" "second, third, ..." paragraph) - (send/suspend - (lambda (url) - `(html - (title ,title) - (body ([bgcolor "white"]) - (h3 ,title) - (br) - (p ,@paragraph) - (br) - (a ([href ,url]) "Continue"))))) - #t) - - ; (listof Xexpr) -> true - (define (inform/html stuff) - (send/suspend - (lambda (url) - `(html - (title "Information") - (body ([bgcolor "white"]) - (hr) - (div ,@stuff) - (hr) - (a ([href ,url]) "Continue"))))) - #t) - - ; String String *-> true - ; to deliver a final web page and terminate the web dialog - (define (final-page title . paragraph) - (check-arg 'final-page (string? title) "string" "first" title) - (check-arg 'final-page (andmap string? paragraph) - "list of strings" "second, third, ..." paragraph) - (send/finish + (define-syntax (define-checked stx) + (syntax-case stx () + [(_ (name pred? ...)) + (let ([make-variable + ; String SyntaxObject -> SyntaxObject + (lambda (x y) + (datum->syntax + stx + (string->symbol + (format "~a-~a" x (syntax->datum y)))))]) + (with-syntax ([make-name (make-variable "make" (syntax name))] + [(x ...) (generate-temporaries (syntax (pred? ...)))]) + (syntax + (set! make-name + (let ([make-name make-name]) + (lambda (x ...) + (check-arg 'make-name (pred? x) pred? "an" x) + ... + (make-name x ...)))))))])) + ; _ -> true + (define (true? x) #t) + + ;; Structure Definitions ---------------------------------------------------- + (define-struct fe (question)) + + (define-struct (password fe)()) + (define-struct (numeric fe) ()) + (define-struct (check fe) ()) + (define-struct (yes-no fe) (positive negative)) + (define-struct (radio fe) (labels)) + + (define-checked (password string?)) + (define-checked (numeric string?)) + (define-checked (check string?)) + (define (list-of-strings? l) + (and (list? l) (andmap string? l))) + (define-checked (radio string? list-of-strings?)) + (define-checked (yes-no string? true? true?)) + + ; todo + (define-struct (button fe) ()) + + + ; _ -> (union true String) + (define (form? x) + (cond + [(not (list? x)) (format "list expected, given ~e" x)] + [(find-non list? x) + => + (lambda (non-list) + (format "list of lists expected, give list with ~e" non-list))] + [(find-non + (lambda (x) + (and (list? x) + (= (length x) 2) + (symbol? (car x)) + (form-element? (cadr x)))) + x) + => + (lambda (non-tagged-fe) + (format "list of (list Symbol FormElement) expected, given ~s" non-tagged-fe))] + [else true])) + + ; _ -> Boolean + (define (form-element? x) + (cond + [(string? x) #t] + [(fe? x) (and + (string? (fe-question x)) + (cond + [(radio? x) (and (non-empty-list? (radio-labels x)) + (andmap string? (radio-labels x)))] + [(yes-no? x) (and (string? (yes-no-positive x)) + (string? (yes-no-negative x)))] + [else #t]))] + [else #f])) + + ; _ -> Boolean + (define (non-empty-list? x) + (and (cons? x) (list? x))) + + ; + ;; ;; + ;; ;; + ;; ;; ;;;; ;;; ; ;;; ;;; + ; ; ; ; ; ;; ; ; ; + ; ; ; ;;;; ; ; ; ;;; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ; ;;;;; ;;; ;; ;;; + + + ; posing questions ---------------------------------------------------------- + + ; FormElement -> Answer + ; to pose one question, receive one answer + (define (internal:single-query fe) + (check-arg 'single-query (form-element? fe) "form element" "first" fe) + (car (internal:queries (list fe)))) + + ; (listof FormElement) -> (listof Answer) + ; to ask N questions and to get N answers + ; assert: (lambda (result) (= (length fes) (length result))) + (define (internal:queries fes) + (check-arg 'queries (and (list? fes) (andmap form-element? fes)) + "list of form elements" "first" fes) + (conduct-query "Web Query" (map list (make-keys fes) fes))) + + ; Form -> Bindings + ; to ask N questions with tags, receive N answers + ; assert: (lambda (result) (set-equal? (map car aloss) (map car result))) + (define (internal:form-query f) + (check-list-list 'form-query (form? f) "form" f) + (map list (map first f) + (conduct-query "Web Query" (map list (make-keys f) (map second f))))) + + + ; extracting values from forms ---------------------------------------------- + + ; extract : Symbol Response -> (listof Answer) + ; extract all answers associated with a tag + (define (extract tag r) + (map second (filter (lambda (a) (eq? (first a) tag)) r))) + + ; extract/single : Symbol Response -> Answer + (define (extract/single tag r) + (let ([all (extract tag r)]) + (if (and (pair? all) (null? (rest all))) ; (= (length all) 1) + (first all) + (cond + [(null? all) + (error 'extract/single "~e contains no tag ~e" r tag)] + [else + (error 'extract/single "~e contains more than one tag ~e" r tag)])))) + + ; echoing responses --------------------------------------------------------- + + ; Response -> true + ; to display a response on a web page + (define (internal:echo-response form) + (make-echo-page + (map (lambda (tag answer) + `(tr (td ,(symbol->string tag)) + (td ,(answer->string answer)))) + (map first form) + (map second form)))) + + ; (listof Answer) -> true + ; to display a list of answers on a web page + (define (internal:echo-answers form) + (make-echo-page + (map (lambda (answer) `(tr (td ,(answer->string answer)))) form))) + + ; displaying information ---------------------------------------------------- + + ; String String *-> true + ; to deliver an intermediate message and a link to continue + (define (internal:inform title . paragraph) + (check-arg 'inform (string? title) "string" "first" title) + (check-arg 'inform (andmap string? paragraph) + "list of strings" "second, third, ..." paragraph) + (servlet:send/suspend + (lambda (url) + `(html + (title ,title) + (body ([bgcolor "white"]) + (h3 ,title) + (br) + (p ,@paragraph) + (br) + (a ([href ,url]) "Continue"))))) + #t) + + + + ; (listof Xexpr) -> true + (define (internal:inform/html stuff) + (servlet:send/suspend + (lambda (url) + `(html + (title "Information") + (body ([bgcolor "white"]) + (hr) + (div ,@stuff) + (hr) + (a ([href ,url]) "Continue"))))) + #t) + + ; String String *-> true + ; to deliver a final web page and terminate the web dialog + (define (internal:final-page title . paragraph) + (check-arg 'final-page (string? title) "string" "first" title) + (check-arg 'final-page (andmap string? paragraph) + "list of strings" "second, third, ..." paragraph) + (servlet:send/finish + `(html + (title ,title) + (body ([bgcolor "white"]) + (h3 ,title) + (br) + (p ,@paragraph)))) + #t) + + + ; ;;; ; ; + ;;; ; + ; ; + ; ; ;; ;; ;;; ;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;;; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ;;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ;;; ;; ;;;;; ;;;;;; ;;;;; ;;; ; ;;;; ;;;;; ;;; ;;; + + ; String Form -> FormResults + (define (conduct-query text aloss) + (let ([keys (map car aloss)]) + (let cq ([text text]) + (let ([res (build-form text aloss)]) + (let/ec restart + (map (lambda (k fe) + (get-binding restart (string->symbol k) res (cadr fe) cq)) + keys aloss)))))) + + ; String (String -> (listof Answer)) -> (listof Answer) + (define (handle message cq n) + (cq `(font ([color "red"]) ,(string-append message " " (fe-question n))))) + + ; Continuation Symbol Bindings FormElement -> Answer + ; effect: raise 'yes-no if a yes-no button goes unchecked + (define (get-binding restart tag bindings fe cq) + (let ([cq (compose restart cq)] + [result (servlet:extract-bindings tag bindings)] + [question "Please respond to the question:"]) + (cond + [(check? fe) (if (null? result) #f #t)] + [(numeric? fe) + (if (null? result) + (handle question cq fe) + (let ([r (string->number (car result))] + [question "Please respond with a number to the question:"]) + (if r r (handle question cq fe))))] + [(yes-no? fe) + (if (null? result) (handle question cq fe) (car result))] + [(radio? fe) + (if (null? result) (handle question cq fe) (car result))] + [(button? fe) ; at most one button should be clicked + (if (null? result) #f (car result))] + [(null? result) (format "error ~e -> ~e :: ~e" tag fe bindings)] + [else (car result)]))) + + ; String Form -> FormResults + ; assert: (lambda (result) (set-equal? (domain aloss) (domain result))) + (define (build-form title f) + (servlet:request-bindings + (servlet:send/suspend + (lambda (url) `(html (title ,title) (body ([bgcolor "white"]) (h3 ,title) (br) - (p ,@paragraph)))) - #t) - - - ; ;;; ; ; - ;;; ; - ; ; - ; ; ;; ;; ;;; ;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;;; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;; ;;; ;;; ;;; ;; ;;;;; ;;;;;; ;;;;; ;;; ; ;;;; ;;;;; ;;; ;;; - - ; String Form -> FormResults - (define (conduct-query text aloss) - (let ([keys (map car aloss)]) - (let cq ([text text]) - (let ([res (build-form text aloss)]) - (let/ec restart - (map (lambda (k fe) - (get-binding restart (string->symbol k) res (cadr fe) cq)) - keys aloss)))))) - - ; String (String -> (listof Answer)) -> (listof Answer) - (define (handle message cq n) - (cq `(font ([color "red"]) ,(string-append message " " (fe-question n))))) - - ; Continuation Symbol Bindings FormElement -> Answer - ; effect: raise 'yes-no if a yes-no button goes unchecked - (define (get-binding restart tag bindings fe cq) - (let ([cq (compose restart cq)] - [result (extract-bindings tag bindings)] - [question "Please respond to the question:"]) - (cond - [(check? fe) (if (null? result) #f #t)] - [(numeric? fe) - (if (null? result) - (handle question cq fe) - (let ([r (string->number (car result))] - [question "Please respond with a number to the question:"]) - (if r r (handle question cq fe))))] - [(yes-no? fe) - (if (null? result) (handle question cq fe) (car result))] - [(radio? fe) - (if (null? result) (handle question cq fe) (car result))] - [(button? fe) ; at most one button should be clicked - (if (null? result) #f (car result))] - [(null? result) (format "error ~e -> ~e :: ~e" tag fe bindings)] - [else (car result)]))) - - ; String Form -> FormResults - ; assert: (lambda (result) (set-equal? (domain aloss) (domain result))) - (define (build-form title f) - (request-bindings - (send/suspend - (lambda (url) - `(html - (title ,title) - (body ([bgcolor "white"]) - (h3 ,title) - (br) - (form ([action ,url][method "post"]) - (table ,@(map build-row f)) - ,@(add-submit-button (map second f))))))))) - - ; build-row : (list Symbol FormElement) -> Xexpr[tr] - (define (build-row x) - (let* ([tag (first x)] - [fe (second x)] - [rad (lambda (x) - `(td (input ([type "radio"][name ,tag][value ,x])) " " ,x))] - [make-radio - (lambda (loq) `(td (table (tr ,@(map rad loq)))))]) - (cond - [(string? fe) - `(tr (td ,fe) (td (input ([type "text"][name ,tag][value ""]))))] - [(password? fe) - `(tr (td ,(fe-question fe)) - (td (input ([type "password"][name ,tag]))))] - [(numeric? fe) - `(tr (td ,(fe-question fe)) - (td (input ([type "text"][name ,tag]))))] - [(check? fe) - `(tr (td ,(fe-question fe)) - (td (input ([type "checkbox"][name ,tag][value ,(fe-question fe)]))))] - [(yes-no? fe) - `(tr (td ,(fe-question fe)) - ,(make-radio (list (yes-no-positive fe) (yes-no-negative fe))))] - [(radio? fe) - `(tr (td ,(fe-question fe)) ,(make-radio (radio-labels fe)))] - [(button? fe) - `(tr (td) - (td (input ([type "submit"][name ,tag][value ,(fe-question fe)]))))] - [else (error 'build-row "can't happen: ~e" fe)]))) - - ; (listof Forms) -> (union Empty (list SUBMIT-BUTTON)) - (define (add-submit-button fes) - (if (pair? (cdr fes)) - (if (ormap button? fes) '() (list SUBMIT-BUTTON)) - (let ([fe (car fes)]) - (if (or (string? fe) (password? fe) (numeric? fe)) - '() - (list SUBMIT-BUTTON))))) - - ;; ;; - ;;; ; ; - ; ; ; ; - ; ; ; ;; ;;; ;;; ; ;; ;;; - ; ;; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;; ; ;; ;;; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ;;; ;;; ;;; ;;; ;;; ;; ;; ;;; - - - ; Answer -> String - (define (answer->string a) - (cond - [(string? a) (format "~s" a)] - [(number? a) (number->string a)] - [(boolean? a) (if a "true" "false")] - [else (format "~a" a)])) - - ; --------------------------------------------------------------------------- - ; (listof X) -> (listof String) - ; make unique, readable string/tags for a list of queries - (define make-keys - (let ([counter 0]) - (lambda (fes) - (map (lambda (x) - (set! counter (+ counter 1)) - (format "tag~a" counter)) - fes)))) - - ; --------------------------------------------------------------------------- - ; (listof Xexpr[tr]) -> true - ; echo stuff, wait for click on continue link - (define (make-echo-page stuff) - (send/suspend - (lambda (url) - `(html - (title "Echoed Answers") - (body ([bgcolor "white"]) - (br) - (table - ,@stuff) - (br) - (a ([href ,url]) "Continue"))))) - #t) - - ; constants ----------------------------------------------------------------- - (define SUBMIT-BUTTON '(input ([type "submit"][value "Submit"]))) - ) + (form ([action ,url][method "post"]) + (table ,@(map build-row f)) + ,@(add-submit-button (map second f))))))))) + + ; build-row : (list Symbol FormElement) -> Xexpr[tr] + (define (build-row x) + (let* ([tag (first x)] + [fe (second x)] + [rad (lambda (x) + `(td (input ([type "radio"][name ,tag][value ,x])) " " ,x))] + [make-radio + (lambda (loq) `(td (table (tr ,@(map rad loq)))))]) + (cond + [(string? fe) + `(tr (td ,fe) (td (input ([type "text"][name ,tag][value ""]))))] + [(password? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "password"][name ,tag]))))] + [(numeric? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "text"][name ,tag]))))] + [(check? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "checkbox"][name ,tag][value ,(fe-question fe)]))))] + [(yes-no? fe) + `(tr (td ,(fe-question fe)) + ,(make-radio (list (yes-no-positive fe) (yes-no-negative fe))))] + [(radio? fe) + `(tr (td ,(fe-question fe)) ,(make-radio (radio-labels fe)))] + [(button? fe) + `(tr (td) + (td (input ([type "submit"][name ,tag][value ,(fe-question fe)]))))] + [else (error 'build-row "can't happen: ~e" fe)]))) + + ; (listof Forms) -> (union Empty (list SUBMIT-BUTTON)) + (define (add-submit-button fes) + (if (pair? (cdr fes)) + (if (ormap button? fes) '() (list SUBMIT-BUTTON)) + (let ([fe (car fes)]) + (if (or (string? fe) (password? fe) (numeric? fe)) + '() + (list SUBMIT-BUTTON))))) + + ;; ;; + ;;; ; ; + ; ; ; ; + ; ; ; ;; ;;; ;;; ; ;; ;;; + ; ;; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ;; ;;; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ;;; ;;; ;; ;; ;;; + + + ; Answer -> String + (define (answer->string a) + (cond + [(string? a) (format "~s" a)] + [(number? a) (number->string a)] + [(boolean? a) (if a "true" "false")] + [else (format "~a" a)])) + + ; --------------------------------------------------------------------------- + ; (listof X) -> (listof String) + ; make unique, readable string/tags for a list of queries + (define make-keys + (let ([counter 0]) + (lambda (fes) + (map (lambda (x) + (set! counter (+ counter 1)) + (format "tag~a" counter)) + fes)))) + + ; --------------------------------------------------------------------------- + ; (listof Xexpr[tr]) -> true + ; echo stuff, wait for click on continue link + (define (make-echo-page stuff) + (servlet:send/suspend + (lambda (url) + `(html + (title "Echoed Answers") + (body ([bgcolor "white"]) + (br) + (table + ,@stuff) + (br) + (a ([href ,url]) "Continue"))))) + #t) + + ; constants ----------------------------------------------------------------- + (define SUBMIT-BUTTON '(input ([type "submit"][value "Submit"]))) + + + + + ; + ; + ; + ; ;;;; + ; ;; ; + ; ; ;;; ; ;; ; ; ;;; ; ;; + ; ;; ;; ; ;; ; ; ; ;; ; ;; ; + ; ;;;; ; ; ; ; ; ; ; ; + ; ;; ;;;;; ; ; ; ;;;;; ; + ; ; ; ; ;;; ; ; + ; ; ;; ;; ; ; ; ;; ; ; + ; ;;;; ;;; ; ; ;;; ; + ; + ; + ; ; ;; + + + ;; Returns the next port over 8000 that we can try + (define (get-next-port) + (define starting-at 8000) + (define max-attempts 32) + (let loop ([port-no starting-at] + [attempts 0]) + (let ([port-available? + (with-handlers ([exn:fail:network? + (lambda (exn) #f)]) + (let ([listener (tcp-listen port-no 4 #t #f)]) + (tcp-close listener) + #t))]) + (cond + [port-available? + port-no] + [(< attempts max-attempts) + (loop (add1 port-no) (add1 attempts))] + [else + (error 'get-next-port + "Couldn't find an available port between ~a and ~a~n" + starting-at (+ starting-at max-attempts))])))) + + + + (define in-ch (make-parameter (make-channel))) + (define current-server (make-parameter #f)) + + ;; A request is a (make-req thunk res-ch) where thunk is a (-> any) and res-ch is a + ;; channel. + (define-struct req ()) + (define-struct (req:standard req) (thunk res-ch)) + (define-struct (req:stop-server req) (thunk res-ch)) + + ;; An error response holds the exception that happened. + (define-struct error-res (exn)) + + ;; A server consists of the maintenance thread. + (define-struct server (t) #:mutable) + + ;; ensure-standalone-server-running!: -> void + ;; Makes sure that the standalone server is up and running. + (define (ensure-standalone-server-running!) + (unless (current-server) + (let ([a-server (make-server #f)]) + (current-server a-server) + (thread (lambda () + (set-server-t! a-server (current-thread)) + (let ([port (get-next-port)]) + (servlet:on-web port (begin + (servlet:adjust-timeout! +inf.0) + (server-loop a-server))))))))) + + (define (server-loop a-server) + (let loop () + (let ([msg (channel-get (in-ch))]) + (match msg + + [(struct req:stop-server (thunk res-ch)) + (channel-put res-ch (with-handlers ([void make-error-res]) + (thunk))) + (current-server #f)] + + [(struct req:standard (thunk res-ch)) + (channel-put res-ch (with-handlers ([void make-error-res]) + (thunk))) + (loop)])))) + + + (define (make-wrapped-function internal:function make-request) + (lambda args + (ensure-standalone-server-running!) + (let ([res-ch (make-channel)]) + (channel-put (in-ch) + (make-request (lambda () (apply internal:function args)) + res-ch)) + (let ([result + (channel-get res-ch)]) + (cond + [(error-res? result) + (raise (error-res-exn result))] + [else + result]))))) + + ;; Provides wrappers around the internal functions to make the wrapped functions + ;; run in the context of a standalone server. + (define-syntax (define-wrapped-function stx) + (syntax-case stx () + [(_ function internal:function #:final final) + (with-syntax ([make-request (if (syntax->datum #'final) + #'make-req:stop-server + #'make-req:standard)]) + (syntax/loc stx + (define function (make-wrapped-function internal:function make-request))))] + + [(_ function internal:function) + (syntax/loc stx + (define-wrapped-function function internal:function #:final #f))])) + + + (define-wrapped-function single-query internal:single-query) + (define-wrapped-function queries internal:queries) + (define-wrapped-function echo-answers internal:echo-answers) + + (define-wrapped-function form-query internal:form-query) + (define-wrapped-function echo-response internal:echo-response) + + (define-wrapped-function inform/html internal:inform/html) + (define-wrapped-function inform internal:inform) + + + ;; fixme: on final-page, send/finish seems to stop the thread. + (define-wrapped-function final-page internal:final-page #:final #t) + + (define-wrapped-function send/suspend servlet:send/suspend) + (define-wrapped-function send/finish servlet:send/finish))