diff --git a/collects/htdp/servlet2.ss b/collects/htdp/servlet2.ss index b454aa1591..570c6ce8ab 100644 --- a/collects/htdp/servlet2.ss +++ b/collects/htdp/servlet2.ss @@ -1,49 +1,50 @@ -(module servlet2 scheme/base - #| TODO ----------------------------------------------------------------------- +#lang scheme/base + +#| TODO ----------------------------------------------------------------------- buttons: multiple points of returns: continuation functions |# - (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 -------------------------------------------------------- +(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) @@ -59,20 +60,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? @@ -80,492 +81,503 @@ 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 - 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 +(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)))) - #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) - (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) + (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 - [(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))]) + [(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) + (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"]))) + + + + +; +; +; +; ;;;; +; ;; ; +; ; ;;; ; ;; ; ; ;;; ; ;; +; ;; ;; ; ;; ; ; ; ;; ; ;; ; +; ;;;; ; ; ; ; ; ; ; ; +; ;; ;;;;; ; ; ; ;;;;; ; +; ; ; ; ;;; ; ; +; ; ;; ;; ; ; ; ;; ; ; +; ;;;; ;;; ; ; ;;; ; +; +; +; ; ;; + + +;; get-next-port: -> number +;; Returns the next port, starting from 8000, that's available. +;; If we can't get one after max-attempt tries, give up and raise +;; an error. +(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))])))) + + +;; the current-server is a (make-parameter (or/c #f a-server)) +;; where a-server is a server, defined below. +(define current-server (make-parameter #f)) + + +;; A server consists of the maintenance thread, the request and response channels. +(define-struct server (th req-ch res-ch)) + + +;; A request is either a +;; (make-req:standard f args) +;; or a +;; (make-req:final f args) +;; where f is a function that consumes args. +(define-struct req (func args)) +(define-struct (req:standard req) ()) +(define-struct (req:final req) ()) + +;; If an exception happens when evaluating a request, we +;; return an error response. exn holds the exception that happened. +(define-struct error-res (exn)) + + +;; ensure-standalone-server-running!: -> void +;; Initializes the current-server parameter. +;; Makes sure that the standalone server is up and running. +(define (ensure-standalone-server-running!) + (unless (current-server) + (let* ([req-ch (make-channel)] + [res-ch (make-channel)] + [server-loop + (lambda () + (servlet:adjust-timeout! +inf.0) + (let loop () + (let ([msg (channel-get req-ch)]) + (match msg + + [(struct req:final (func args)) + (channel-put res-ch (with-handlers ([void make-error-res]) + (apply func args)))] + + [(struct req:standard (func args)) + (channel-put res-ch (with-handlers ([void make-error-res]) + (apply func args))) + (loop)]))))] + [th + (thread (lambda () + (let ([port (get-next-port)]) + (servlet:on-web port (server-loop)))))] + [a-server (make-server th req-ch res-ch)]) + (current-server a-server)))) + + + +;; Each of the wrapped functions turns function calls into requests +;; to the server. +(define (make-wrapped-function internal:function make-req) + (lambda args + (ensure-standalone-server-running!) + (let ([req (make-req internal:function args)]) + (channel-put (server-req-ch (current-server)) req) + (let ([result (channel-get (server-res-ch (current-server)))]) (cond - [port-available? - port-no] - [(< attempts max-attempts) - (loop (add1 port-no) (add1 attempts))] + [(error-res? result) + (raise (error-res-exn result))] [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)) + 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:final + #'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 a final-page, send/finish doesn't seem to return control. +(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 #:final #t)