suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Getting servlet2 back to working shape. Changes include:

Browse Source 
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
This commit is contained in:
Danny Yoo 2008-07-17 02:13:46 +00:00
parent c96bfce485
commit f237af6140
1 changed files with 543 additions and 396 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

939
collects/htdp/servlet2.ss
View File

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