privacy
svn: r4384
This commit is contained in:
Jay McCarthy
parent
01dac7fa1e
commit
10ab002a3e
|
|
@ -1,12 +1,12 @@
|
|||
; Author: Paul Graunke
|
||||
#cs(module servlet mzscheme
|
||||
(require (lib "servlet-env.ss" "web-server")
|
||||
(require (lib "servlet-env.ss" "web-server" "tools")
|
||||
(lib "error.ss" "htdp")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "list.ss")
|
||||
(lib "prim.ss" "lang")
|
||||
(lib "unitsig.ss"))
|
||||
(provide (all-from-except (lib "servlet-env.ss" "web-server") build-suspender)
|
||||
(provide (all-from-except (lib "servlet-env.ss" "web-server" "tools") build-suspender)
|
||||
(rename wrapped-build-suspender build-suspender))
|
||||
|
||||
(define wrapped-build-suspender
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@
|
|||
#| TODO -----------------------------------------------------------------------
|
||||
buttons: multiple points of returns: continuation functions
|
||||
|#
|
||||
(require (lib "servlet-env.ss" "web-server")
|
||||
(require (lib "servlet-env.ss" "web-server" "tools")
|
||||
(lib "error.ss" "htdp")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss"))
|
||||
(provide (all-from (lib "servlet-env.ss" "web-server"))
|
||||
(provide (all-from (lib "servlet-env.ss" "web-server" "tools"))
|
||||
|
||||
single-query ; FormElement -> Answer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
(module url mzscheme
|
||||
(module servlet-url mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "struct.ss"))
|
||||
(require "private/url.ss"
|
||||
"request-structs.ss")
|
||||
(require "url.ss"
|
||||
"../request-structs.ss")
|
||||
|
||||
(define-struct servlet-url (protocol host port
|
||||
servlets-root
|
||||
|
|
@ -40,10 +40,10 @@
|
|||
[send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)]
|
||||
[send/suspend/callback (xexpr/callback? . -> . any/c)])
|
||||
|
||||
(require "url.ss")
|
||||
(require "private/servlet-url.ss")
|
||||
(provide (all-from "private/web-cells.ss")
|
||||
(all-from "private/servlet-helpers.ss")
|
||||
(all-from "url.ss")
|
||||
(all-from "private/servlet-url.ss")
|
||||
(all-from "servlet-structs.ss"))
|
||||
|
||||
;; ************************************************************
|
||||
|
|
|
|||
|
|
@ -1,94 +0,0 @@
|
|||
(module backend-servlet-testing mzscheme
|
||||
(require (lib "connection-manager.ss" "web-server")
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
"backend.ss"
|
||||
(lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "match.ss")
|
||||
(lib "private/url.ss" "web-server"))
|
||||
|
||||
(provide run-servlet simple-start-servlet simple-resume-servlet)
|
||||
|
||||
;; run-servlet: bindings (listof bindings) (-> response) -> boolean
|
||||
;; feed a bunch of requests to a servlet
|
||||
(define (run-servlet bdg0 bdgs svt)
|
||||
(let ((resp (simple-start-servlet
|
||||
(new-request/url
|
||||
(embed-url-bindings bdg0 (string->url "")))
|
||||
svt)))
|
||||
(or (null? bdgs)
|
||||
(resume-test bdgs (form->k-url resp)))))
|
||||
|
||||
;; resume-test: (listof (listof (cons symbol string))) url -> boolean
|
||||
;; having a gotten a response, feed a bunch of requests to a servlet
|
||||
(define (resume-test bdgs a-url)
|
||||
(or (null? bdgs)
|
||||
(let* ([resp (simple-resume-servlet
|
||||
(new-request/url (embed-url-bindings (car bdgs) a-url))
|
||||
a-url)]
|
||||
[next-url (form->k-url resp)])
|
||||
(resume-test (cdr bdgs) next-url))))
|
||||
|
||||
|
||||
;; Produce the k-url for the form on this page
|
||||
;; TODO: bad cut and paste
|
||||
(define (form->k-url an-xexpr)
|
||||
(string->url
|
||||
(string-append
|
||||
"http://nowhere.com"
|
||||
(let recur ([sub-xexpr an-xexpr])
|
||||
(match sub-xexpr
|
||||
((`form ((attrs rhss) ...) . rest)
|
||||
(ormap (lambda (attr rhs) (and (eqv? attr 'action) rhs))
|
||||
attrs rhss))
|
||||
((tag (attrs ...) body ...) (ormap recur body))
|
||||
(else #f))))))
|
||||
|
||||
;; ****************************************
|
||||
|
||||
(define the-instance-table (make-hash-table))
|
||||
(define the-instance-timeout 10)
|
||||
|
||||
;; simple-start-servlet: request (-> response) -> response
|
||||
;; run the servlet until it produces a response
|
||||
(define (simple-start-servlet req svt)
|
||||
(let* ([i-port (open-input-string "")]
|
||||
[o-port (open-output-string)]
|
||||
[conn (new-connection 86400 i-port o-port (make-custodian) #t)])
|
||||
(start-servlet conn req the-instance-table the-instance-timeout
|
||||
(lambda (adjust-timeout! initial-request)
|
||||
(svt)))
|
||||
(let ([i-p (open-input-string (get-output-string o-port))])
|
||||
(purify-port i-p)
|
||||
(xml->xexpr (read-xml/element i-p)))))
|
||||
|
||||
;; simple-resume-servlet: request url -> response
|
||||
;; resume the servlet continuation until it produces a response
|
||||
(define (simple-resume-servlet req url)
|
||||
(let* ([k-ref (continuation-url? url)]
|
||||
[i-port (open-input-string "")]
|
||||
[o-port (open-output-string)]
|
||||
[conn (new-connection 86400 i-port o-port (make-custodian) #t)])
|
||||
(resume-servlet conn req k-ref the-instance-table)
|
||||
(let ([i-p (open-input-string (get-output-string o-port))])
|
||||
(purify-port i-p)
|
||||
(xml->xexpr (read-xml/element i-p)))))
|
||||
|
||||
;; embed-url-bindings: (listof (cons symbol string)) url -> url
|
||||
;; encode bindings in a url
|
||||
(define (embed-url-bindings env in-url)
|
||||
(let* ((query (url-query in-url))
|
||||
(old-env (or query '())))
|
||||
(make-url
|
||||
(url-scheme in-url)
|
||||
(url-user in-url)
|
||||
(url-host in-url)
|
||||
(url-port in-url)
|
||||
(url-path in-url)
|
||||
(append env old-env)
|
||||
(url-fragment in-url))))
|
||||
|
||||
;; Produce a new request, with an url
|
||||
(define (new-request/url new-url)
|
||||
(make-request
|
||||
'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip")))
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
(module backend mzscheme
|
||||
(require (lib "servlet.ss" "web-server")
|
||||
(lib "timer.ss" "web-server")
|
||||
(lib "response.ss" "web-server")
|
||||
(lib "connection-manager.ss" "web-server"))
|
||||
|
||||
(provide start-servlet resume-servlet)
|
||||
|
||||
;; make-servlet-custodian: -> custodian
|
||||
(define make-servlet-custodian
|
||||
(let ([cust (current-custodian)])
|
||||
(lambda () (make-custodian cust))))
|
||||
|
||||
;; start-servlet: connection request hash-table number (number->void request -> response) -> void
|
||||
;; start a new instance of a servlet
|
||||
(define (start-servlet conn req instance-table instance-timeout svt)
|
||||
(define sema (make-semaphore 0))
|
||||
(define response
|
||||
(let/cc suspend
|
||||
(let* ([servlet-custodian (make-servlet-custodian)]
|
||||
[inst (create-new-instance!
|
||||
instance-table servlet-custodian
|
||||
(make-execution-context
|
||||
conn req suspend)
|
||||
sema)]
|
||||
[servlet-exit-handler (make-servlet-exit-handler inst instance-table)]
|
||||
[time-bomb (start-timer instance-timeout
|
||||
(lambda () (servlet-exit-handler #f)))])
|
||||
(parameterize ([current-custodian servlet-custodian]
|
||||
[current-servlet-instance inst]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(make-servlet-exception-handler inst)])
|
||||
(let ([r (svt (lambda (secs)
|
||||
(reset-timer! time-bomb secs))
|
||||
req)])
|
||||
(when (response? r)
|
||||
(send/back r))))))))
|
||||
(output-respose conn response)
|
||||
(semaphore-post sema))
|
||||
|
||||
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
|
||||
;; exit handler for a servlet
|
||||
(define (make-servlet-exit-handler inst instance-table)
|
||||
(lambda (x)
|
||||
(remove-instance! instance-table inst)
|
||||
(kill-connection!
|
||||
(execution-context-connection
|
||||
(servlet-instance-context inst)))
|
||||
(custodian-shutdown-all (servlet-instance-custodian inst))))
|
||||
|
||||
;; make-servlet-exception-handler: host -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
(define (make-servlet-exception-handler inst)
|
||||
(lambda (the-exn)
|
||||
(let* ([ctxt (servlet-instance-context inst)]
|
||||
[req (execution-context-request ctxt)])
|
||||
(output-response/method
|
||||
(execution-context-connection ctxt)
|
||||
`(html (head (title "Error"))
|
||||
(body
|
||||
(p "there was an error:")
|
||||
(p ,(exn-message the-exn))))
|
||||
(request-method req))
|
||||
((execution-context-suspend ctxt)))))
|
||||
|
||||
;; resume-servlet: connection request continuation-reference hash-table -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (resume-servlet conn req k-ref instance-table)
|
||||
(define inst (hash-table-get instance-table (car k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet:instance
|
||||
"" (current-continuation-marks))))))
|
||||
(define k-table
|
||||
(servlet-instance-k-table inst))
|
||||
(define response
|
||||
(let/cc suspend
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req suspend))
|
||||
(semaphore-wait (servlet-instance-mutex inst))
|
||||
((hash-table-get k-table (cadr k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet:continuation
|
||||
"" (current-continuation-marks)))))
|
||||
req)))
|
||||
(output-response conn response)
|
||||
(semaphore-post (servlet-instance-mutex inst))))
|
||||
|
|
@ -1,165 +0,0 @@
|
|||
;; Drive a servlet. Pretend to be a Web browser, and send a request to the
|
||||
;; server. Produce the response.
|
||||
|
||||
(module send-assertions mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "test.ss" "schemeunit")
|
||||
(lib "etc.ss")
|
||||
(lib "match.ss")
|
||||
"servlet-testing-framework.ss"
|
||||
(lib "servlet.ss" "web-server"))
|
||||
|
||||
(provide
|
||||
assert-output-response/suspended
|
||||
(struct unknown ())
|
||||
hyperlink->k-url
|
||||
form->k-url)
|
||||
|
||||
;; The unknown value
|
||||
(define-struct unknown () (make-inspector))
|
||||
|
||||
#|
|
||||
(define in?
|
||||
(or/c
|
||||
(list-immutable/c (xexpr/callback? . -> . string?)
|
||||
(listof (cons/c symbol? string?)))
|
||||
(symbols 'back 'forward)
|
||||
(list-immutable/c (xexpr/callback? . -> . string?)
|
||||
(listof (cons/c symbol? string?))
|
||||
(listof (cons/c symbol? string?)))))
|
||||
|#
|
||||
|
||||
;; Ensure output-response produces the right value. Feed the send/suspends.
|
||||
;; (-> response) (listof in?) xexpr? . -> . boolean?
|
||||
(define (assert-output-response/suspended outputter ins out)
|
||||
(special-equal?
|
||||
(assert-loop ins (start-servlet outputter) 0 '())
|
||||
out))
|
||||
|
||||
;; A history is a
|
||||
;; (make-history string? (listof (cons/p symbol? string?))
|
||||
;; (or/c #f (listof (cons/p symbol? string?)))
|
||||
(define-struct history (k-url bindings headers))
|
||||
|
||||
;; Go over the input list, resuming the servlet on each choice, until the
|
||||
;; end. Support the back-button with an indexed list.
|
||||
;; This is written in a pattern-matching style to increment/decrement the
|
||||
;; counter correctly, and do any sanity checks (e.g. 'forward after a
|
||||
;; non-'back).
|
||||
(define (assert-loop ins r i hs)
|
||||
(let ((forward-error (make-exn:fail:contract:variable
|
||||
(string->immutable-string
|
||||
"Cannot go forward more times than back")
|
||||
(current-continuation-marks)
|
||||
'blah)))
|
||||
(match ins
|
||||
(('back 'back . ls) (assert-loop (cons 'back ls)
|
||||
(resumer (list-ref hs (add1 i)))
|
||||
(add1 i)
|
||||
hs))
|
||||
(('back 'forward . ls) (assert-loop (cons 'forward ls)
|
||||
(resumer (list-ref hs (add1 i)))
|
||||
(add1 i)
|
||||
hs))
|
||||
(('back l . ls) (assert-loop (cons l ls)
|
||||
(resumer (list-ref hs (add1 i)))
|
||||
0
|
||||
(list-tail hs (add1 i))))
|
||||
(('forward 'back . ls) (if (> i 0)
|
||||
(assert-loop (cons 'back ls)
|
||||
(resumer (list-ref hs (sub1 i)))
|
||||
(sub1 i)
|
||||
hs)
|
||||
(raise forward-error)))
|
||||
(('forward 'forward . ls) (if (> i 0)
|
||||
(assert-loop (cons 'forward ls)
|
||||
(resumer (list-ref hs (sub1 i)))
|
||||
(sub1 i)
|
||||
hs)
|
||||
(raise forward-error)))
|
||||
(('forward l . ls) (if (> i 0)
|
||||
(assert-loop (cons l ls)
|
||||
(resumer (list-ref hs (sub1 i)))
|
||||
0
|
||||
(list-tail (sub1 i)))
|
||||
(raise forward-error)))
|
||||
((l 'back . ls) (let ((h (history/list l r)))
|
||||
(assert-loop (cons 'back ls)
|
||||
(resumer h)
|
||||
0
|
||||
(cons h hs))))
|
||||
((l n . ls) (if (and (symbol? n) (symbol=? n 'forward))
|
||||
(raise forward-error)
|
||||
(let ((h (history/list l r)))
|
||||
(assert-loop (cons n ls)
|
||||
(resumer h)
|
||||
0
|
||||
(cons h hs)))))
|
||||
(('back) (resumer (list-ref hs (add1 i))))
|
||||
(('forward) (if (> i 0)
|
||||
(resumer (list-ref hs (sub1 i)))
|
||||
(raise forward-error)))
|
||||
((l) (resumer (history/list l r)))
|
||||
((? null?) r))))
|
||||
|
||||
;; history/list : (or/c (list/p (xexpr? . -> . string?)
|
||||
;; (listof (cons/p symbol? string?)))
|
||||
;; (list/p (xexpr? . -> . string?)
|
||||
;; (listof (cons/p symbol? string?))
|
||||
;; (listof (cons/p symbol? string?))))
|
||||
;; response? . -> . history?
|
||||
(define (history/list l r)
|
||||
(let ((k-url ((car l) r)))
|
||||
(if k-url
|
||||
(cond
|
||||
((= (length l) 2) (make-history k-url (cadr l) #f))
|
||||
((= (length l) 3) (make-history k-url (cadr l) (caadr l))))
|
||||
(fail (format "~a~n~v~n~a~v~n"
|
||||
"Failed to match the response" r
|
||||
"with the function" (car l))))))
|
||||
|
||||
;; resumer : history? . -> . response?
|
||||
;; Resume the servlet correctly.
|
||||
(define (resumer a-history)
|
||||
(if (history-headers a-history)
|
||||
(resume-servlet/headers (history-k-url a-history)
|
||||
(history-bindings a-history)
|
||||
(history-headers a-history))
|
||||
(resume-servlet (history-k-url a-history)
|
||||
(history-bindings a-history))))
|
||||
|
||||
;; True if:
|
||||
;; a or b is `unknown'
|
||||
;; a and b are not pairs and are equal?
|
||||
;; a and b are pairs and their car and cdr are special-equal?
|
||||
(define (special-equal? a b)
|
||||
(cond
|
||||
((or (unknown? a) (unknown? b)) #t)
|
||||
((and (not (pair? a)) (not (pair? b))) (equal? a b))
|
||||
((and (pair? a) (pair? b)) (and (special-equal? (car a) (car b))
|
||||
(special-equal? (cdr a) (cdr b))))
|
||||
(else (equal? a b))))
|
||||
|
||||
;; Produce the k-url for the form on this page
|
||||
(define form->k-url
|
||||
(match-lambda
|
||||
((`form ((attrs rhss) ...) . rest)
|
||||
(ormap (lambda (attr rhs) (and (eqv? attr 'action) rhs))
|
||||
attrs rhss))
|
||||
((tag (attrs ...) body ...) (ormap form->k-url body))
|
||||
(else #f)))
|
||||
|
||||
;; Produce the k-url used for the next part of the form
|
||||
;; (xexpr/callback? . -> . (or/c false? string?))
|
||||
(define-syntax hyperlink->k-url
|
||||
(syntax-rules ()
|
||||
((_ str)
|
||||
(letrec ((f (match-lambda
|
||||
(('a ((attrs rhss) (... ...)) str)
|
||||
(ormap (lambda (attr rhs) (and (eqv? attr 'href) rhs))
|
||||
attrs rhss))
|
||||
((tag (attrs (... ...)) body (... ...)) (ormap f body))
|
||||
(else #f))))
|
||||
f))))
|
||||
|
||||
)
|
||||
|
|
@ -1,17 +1,17 @@
|
|||
(module servlet-env mzscheme
|
||||
(require (lib "sendurl.ss" "net")
|
||||
(lib "unitsig.ss"))
|
||||
(require "configuration.ss"
|
||||
"web-server.ss"
|
||||
"sig.ss"
|
||||
"private/util.ss"
|
||||
"response.ss"
|
||||
"managers/timeouts.ss"
|
||||
"private/servlet.ss"
|
||||
"private/cache-table.ss")
|
||||
(require "servlet.ss")
|
||||
(require "../configuration.ss"
|
||||
"../web-server.ss"
|
||||
"../sig.ss"
|
||||
"../private/util.ss"
|
||||
"../response.ss"
|
||||
"../managers/timeouts.ss"
|
||||
"../private/servlet.ss"
|
||||
"../private/cache-table.ss")
|
||||
(require "../servlet.ss")
|
||||
(provide (rename on-web:syntax on-web)
|
||||
(all-from "servlet.ss"))
|
||||
(all-from "../servlet.ss"))
|
||||
|
||||
(define-syntax (on-web:syntax stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
;; The idea is to mimick the entire Web server as part of the framework for
|
||||
;; this testing infrastructure. Copy most of this stuff from v299. The v299 Web
|
||||
;; server was written with the assumption that continuations exist across
|
||||
;; threads; this is not the case in the exp Web server. As a result, only one
|
||||
;; thread should be used at a time.
|
||||
;;
|
||||
;; Since the real send/* are used, with their full continuation table, one can
|
||||
;; use this to fully pretend to be a Web browser, including back buttons and
|
||||
;; cloning Web pages.
|
||||
(module servlet-testing-framework mzscheme
|
||||
(require (lib "match.ss")
|
||||
(lib "list.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "uri-codec.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
|
||||
(lib "servlet.ss" "web-server")
|
||||
(lib "servlet-tables.ss" "web-server")
|
||||
(lib "connection-manager.ss" "web-server")
|
||||
(lib "timer.ss" "web-server"))
|
||||
|
||||
(provide start-servlet resume-servlet resume-servlet/headers)
|
||||
|
||||
;; Start the servlet
|
||||
(define (start-servlet svt)
|
||||
(run-servlet (new-request) svt))
|
||||
|
||||
(define the-instance
|
||||
(make-servlet-instance 'id0 (make-hash-table) 0 (make-semaphore 0)))
|
||||
|
||||
;; new-servlet-context: request o-port (-> void) -> servlet-context
|
||||
(define (new-servlet-context req op suspend )
|
||||
(make-servlet-context
|
||||
the-instance
|
||||
(let ((cust (make-custodian)))
|
||||
(make-connection
|
||||
(start-timer 15 (lambda () (custodian-shutdown-all cust)))
|
||||
(open-input-string "foo") op cust #t))
|
||||
req
|
||||
suspend))
|
||||
|
||||
;; run-servlet: request string -> s-expression
|
||||
;; Run a servlet and return its next response. Note that the servlet may be a
|
||||
;; continuation.
|
||||
(define (run-servlet req svt)
|
||||
(let* ((cust (make-custodian))
|
||||
(result-channel (make-channel))
|
||||
(op (open-output-string))
|
||||
(sc (new-servlet-context
|
||||
req op
|
||||
(make-suspender result-channel op cust))))
|
||||
(parameterize ((current-custodian cust))
|
||||
(thread
|
||||
(lambda ()
|
||||
(thread-cell-set! current-servlet-context sc)
|
||||
(svt))))
|
||||
(channel-get result-channel)))
|
||||
|
||||
;; make-suspender: channel o-port custodian -> (-> void)
|
||||
(define (make-suspender result-channel op cust)
|
||||
(lambda ()
|
||||
(channel-put
|
||||
result-channel
|
||||
(let ((ip (open-input-string (get-output-string op))))
|
||||
(purify-port ip)
|
||||
(xml->xexpr (read-xml/element ip))))))
|
||||
|
||||
(define (resume-servlet/headers prev-url input headers)
|
||||
(with-handlers
|
||||
((exn:fail:contract?
|
||||
(lambda (e)
|
||||
`(html (head (title "Timeout"))
|
||||
(body
|
||||
(p "The transaction referred to by this url is no longer "
|
||||
"active. Please "
|
||||
(a ((href ,(servlet-instance-k-table the-instance)))
|
||||
"restart")
|
||||
" the transaction."))))))
|
||||
(let ((u (string->url prev-url)))
|
||||
(cond
|
||||
((continuation-url? u)
|
||||
=> (lambda (res)
|
||||
(let ((k (hash-table-get (servlet-instance-k-table the-instance)
|
||||
(cadr res)))
|
||||
(new-req (new-request/url+headers
|
||||
(embed-url-bindings input u) headers)))
|
||||
(run-servlet new-req (lambda () (k new-req))))))
|
||||
(else (error "url doesn't encode a servlet continuation"))))))
|
||||
|
||||
;; Resume the servlet
|
||||
(define (resume-servlet prev-url input)
|
||||
(resume-servlet/headers prev-url input '()))
|
||||
|
||||
;; embed-url-bindings: (listof (cons string string)) url -> url
|
||||
;; encode bindings in a url
|
||||
(define (embed-url-bindings env in-url)
|
||||
(let* ((query (url-query in-url))
|
||||
(old-env (or query '())))
|
||||
(make-url
|
||||
(url-scheme in-url)
|
||||
(url-user in-url)
|
||||
(url-host in-url)
|
||||
(url-port in-url)
|
||||
(url-path in-url)
|
||||
(append env old-env)
|
||||
(url-fragment in-url))))
|
||||
|
||||
(define (remove-query an-url)
|
||||
(make-url
|
||||
(url-scheme an-url)
|
||||
(url-user an-url)
|
||||
(url-host an-url)
|
||||
(url-port an-url)
|
||||
(url-path an-url)
|
||||
'()
|
||||
(url-fragment an-url)))
|
||||
|
||||
;; Produce a new request
|
||||
(define (new-request)
|
||||
(new-request/bindings '()))
|
||||
|
||||
;; Produce a new request, with an url
|
||||
(define (new-request/url new-url)
|
||||
(new-request/url+headers new-url '()))
|
||||
|
||||
;; Produce a new request, with an url and headers
|
||||
(define (new-request/url+headers new-url headers)
|
||||
(make-request 'get (remove-query new-url) headers (url-query new-url)
|
||||
"a-host-ip" "a-client-ip"))
|
||||
|
||||
;; Produce a new request, with bindings
|
||||
(define (new-request/bindings bs)
|
||||
(make-request 'get (string->url "http://www.example.com/") '() bs
|
||||
"a-host-ip" "a-client-ip")))
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
(module test-send-assertions mzscheme
|
||||
(require (lib "test.ss" "schemeunit")
|
||||
(lib "servlet.ss" "web-server")
|
||||
"send-assertions.ss"
|
||||
)
|
||||
|
||||
(provide test-send-assertions)
|
||||
|
||||
(define test-send-assertions
|
||||
(make-test-suite
|
||||
"Test the test suite that tests send/*"
|
||||
|
||||
(make-test-case
|
||||
"Test send/finish"
|
||||
(assert-output-response/suspended
|
||||
(lambda () (send/finish '(p "The output")))
|
||||
'()
|
||||
'(p () "The output")))
|
||||
|
||||
(make-test-case
|
||||
"Test send/suspend and send/finish"
|
||||
(assert-output-response/suspended
|
||||
(lambda ()
|
||||
(let ((num (extract-binding/single
|
||||
'num
|
||||
(request-bindings
|
||||
(send/suspend
|
||||
(lambda (k-url)
|
||||
`(form ((action ,k-url)) (input ((name "num"))))))))))
|
||||
(send/finish `(p ,num))))
|
||||
(list (cons (lambda (x) (cadr (car (cadr x))))
|
||||
(list (cons 'num "5"))))
|
||||
'(p () "5")))
|
||||
|
||||
(make-test-case
|
||||
"Test send/suspend/callback once"
|
||||
(assert-output-response/suspended
|
||||
(lambda ()
|
||||
(send/suspend/callback
|
||||
`(p () (a ((href ,(lambda (req) (send/finish '(p "Finished")))))
|
||||
"Next"))))
|
||||
(list (cons (lambda (x) (cadr (car (cadr (caddr x)))))
|
||||
'()))
|
||||
'(p () "Finished")))
|
||||
|
||||
(make-test-case
|
||||
"Test mutual send/suspend/callbacks"
|
||||
(assert-output-response/suspended
|
||||
(lambda ()
|
||||
(letrec ((p1 `(p () (a ((href ,(lambda (req) (send/suspend/callback p2))))
|
||||
"Next")))
|
||||
(p2 `(p () (a ((href ,(lambda (req) (send/suspend/callback p1))))
|
||||
"Previous"))))
|
||||
(send/suspend/callback p1)))
|
||||
(list (cons (lambda (x) (cadr (car (cadr (caddr x))))) '())
|
||||
(cons (lambda (x) (cadr (car (cadr (caddr x))))) '()))
|
||||
`(p () (a ((href ,(make-unknown))) "Next")))))
|
||||
|
||||
)
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user