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
This commit is contained in:
Danny Yoo
parent
c96bfce485
commit
f237af6140
|
|
@ -1,14 +1,17 @@
|
|||
(module servlet2 mzscheme
|
||||
(module servlet2 scheme/base
|
||||
#| TODO -----------------------------------------------------------------------
|
||||
buttons: multiple points of returns: continuation functions
|
||||
|#
|
||||
(require web-server/servlet-env
|
||||
(require (prefix-in servlet: web-server/servlet-env)
|
||||
htdp/error
|
||||
mzlib/list
|
||||
mzlib/etc)
|
||||
(provide (all-from web-server/servlet-env)
|
||||
scheme/tcp
|
||||
scheme/bool
|
||||
scheme/list
|
||||
scheme/match)
|
||||
|
||||
single-query ; FormElement -> Answer
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(provide single-query ; FormElement -> Answer
|
||||
|
||||
queries ; (listof FormElement) -> (listof Answer)
|
||||
echo-answers ; (listof Answers) -> true
|
||||
|
|
@ -24,15 +27,22 @@
|
|||
|
||||
; Structures --------------------------------------------------------------
|
||||
make-password
|
||||
(rename make-numeric make-number)
|
||||
(rename-out (make-numeric make-number)
|
||||
(make-check make-boolean))
|
||||
make-yes-no
|
||||
(rename make-check make-boolean)
|
||||
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
|
||||
|
|
@ -76,10 +86,10 @@
|
|||
(let ([make-variable
|
||||
; String SyntaxObject -> SyntaxObject
|
||||
(lambda (x y)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
stx
|
||||
(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))]
|
||||
[(x ...) (generate-temporaries (syntax (pred? ...)))])
|
||||
(syntax
|
||||
|
|
@ -166,14 +176,14 @@
|
|||
|
||||
; FormElement -> 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)
|
||||
(car (queries (list 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 (queries fes)
|
||||
(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)))
|
||||
|
|
@ -181,7 +191,7 @@
|
|||
; 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)
|
||||
(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)))))
|
||||
|
|
@ -209,7 +219,7 @@
|
|||
|
||||
; Response -> true
|
||||
; to display a response on a web page
|
||||
(define (echo-response form)
|
||||
(define (internal:echo-response form)
|
||||
(make-echo-page
|
||||
(map (lambda (tag answer)
|
||||
`(tr (td ,(symbol->string tag))
|
||||
|
|
@ -219,7 +229,7 @@
|
|||
|
||||
; (listof Answer) -> true
|
||||
; to display a list of answers on a web page
|
||||
(define (echo-answers form)
|
||||
(define (internal:echo-answers form)
|
||||
(make-echo-page
|
||||
(map (lambda (answer) `(tr (td ,(answer->string answer)))) form)))
|
||||
|
||||
|
|
@ -227,11 +237,11 @@
|
|||
|
||||
; String String *-> true
|
||||
; 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 (andmap string? paragraph)
|
||||
"list of strings" "second, third, ..." paragraph)
|
||||
(send/suspend
|
||||
(servlet:send/suspend
|
||||
(lambda (url)
|
||||
`(html
|
||||
(title ,title)
|
||||
|
|
@ -243,9 +253,11 @@
|
|||
(a ([href ,url]) "Continue")))))
|
||||
#t)
|
||||
|
||||
|
||||
|
||||
; (listof Xexpr) -> true
|
||||
(define (inform/html stuff)
|
||||
(send/suspend
|
||||
(define (internal:inform/html stuff)
|
||||
(servlet:send/suspend
|
||||
(lambda (url)
|
||||
`(html
|
||||
(title "Information")
|
||||
|
|
@ -258,11 +270,11 @@
|
|||
|
||||
; String String *-> true
|
||||
; to deliver a final web page and terminate the web dialog
|
||||
(define (final-page title . paragraph)
|
||||
(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)
|
||||
(send/finish
|
||||
(servlet:send/finish
|
||||
`(html
|
||||
(title ,title)
|
||||
(body ([bgcolor "white"])
|
||||
|
|
@ -300,7 +312,7 @@
|
|||
; 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)]
|
||||
[result (servlet:extract-bindings tag bindings)]
|
||||
[question "Please respond to the question:"])
|
||||
(cond
|
||||
[(check? fe) (if (null? result) #f #t)]
|
||||
|
|
@ -322,8 +334,8 @@
|
|||
; String Form -> FormResults
|
||||
; assert: (lambda (result) (set-equal? (domain aloss) (domain result)))
|
||||
(define (build-form title f)
|
||||
(request-bindings
|
||||
(send/suspend
|
||||
(servlet:request-bindings
|
||||
(servlet:send/suspend
|
||||
(lambda (url)
|
||||
`(html
|
||||
(title ,title)
|
||||
|
|
@ -407,7 +419,7 @@
|
|||
; (listof Xexpr[tr]) -> true
|
||||
; echo stuff, wait for click on continue link
|
||||
(define (make-echo-page stuff)
|
||||
(send/suspend
|
||||
(servlet:send/suspend
|
||||
(lambda (url)
|
||||
`(html
|
||||
(title "Echoed Answers")
|
||||
|
|
@ -421,4 +433,139 @@
|
|||
|
||||
; 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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user