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

Removing reliance on SXML and adding little xpath evaluator for xexprs

Browse Source 
svn: r18366
This commit is contained in:
Jay McCarthy 2010-02-26 21:16:56 +00:00
parent d35b0b30cd
commit 1f4ab946e1
5 changed files with 96 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/tests/web-server/dispatchers/dispatch-lang-test.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require schemeunit
(planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
mzlib/etc
mzlib/list
web-server/dispatchers/dispatch
@ -53,11 +52,11 @@
(let* ([xs #"10"]
[ys #"17"]
[d (mkd (build-path example-servlets "add-param.ss"))]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys)))))])
[k0 (simple-xpath* '(form #:action) (call d url0 empty))]
[k1 (simple-xpath* '(form #:action) (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs))))]
[n (simple-xpath* '(p) (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys))))])
n)))
(test-add-two-numbers
@ -77,11 +76,11 @@
(test-equal?
"add01.ss - no s/s, uri"
(let* ([d (mkd (build-path example-servlets "add01.ss"))]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?first=~a" url0 xs) (list (make-binding:form #"first" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?first=~a&second=~a" url0 xs ys)
[k0 (simple-xpath* '(form #:action) (call d url0 empty))]
[k1 (simple-xpath* '(form #:action) (call d (format "~a?first=~a" url0 xs) (list (make-binding:form #"first" xs))))]
[n (simple-xpath* '(p) (call d (format "~a?first=~a&second=~a" url0 xs ys)
(list (make-binding:form #"first" xs)
(make-binding:form #"second" ys)))))])
(make-binding:form #"second" ys))))])
n)
(format "The answer is: ~a" (+ x y))))
@ -134,7 +133,7 @@
(test-equal? "check-dir.ss"
(let* ([d (mkd (build-path example-servlets "check-dir.ss"))]
[t0 (first ((sxpath "//h2/text()") (call d url0 empty)))])
[t0 (simple-xpath* '(h2) (call d url0 empty))])
t0)
(format "The current directory: ~a" (path->string example-servlets)))

23
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require schemeunit
(planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
mzlib/etc
mzlib/list
web-server/http
@ -44,14 +43,14 @@
(test-pred "configure.ss"
string?
(let* ([d (mkd (build-path example-servlets 'up "configure.ss"))]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))])
[k0 (simple-xpath* '(form #:action) (call d url0 empty))])
k0))
(test-suite
"Examples"
(test-equal? "hello.ss - loading"
(let* ([d (mkd (build-path example-servlets "hello.ss"))]
[t0 (first ((sxpath "//p/text()") (call d url0 empty)))])
[t0 (simple-xpath* '(p) (call d url0 empty))])
t0)
"Hello, Web!")
(test-add-two-numbers mkd "add.ss - send/suspend"
@ -66,30 +65,30 @@
(let* ([d (mkd (build-path example-servlets "count.ss"))]
[ext (lambda (c)
(rest (regexp-match #rx"This servlet was called (.+) times and (.+) times since loaded on" c)))]
[c1 (ext (first ((sxpath "//p/text()") (call d url0 empty))))]
[c2 (ext (first ((sxpath "//p/text()") (call d url0 empty))))])
[c1 (ext (simple-xpath* '(p) (call d url0 empty)))]
[c2 (ext (simple-xpath* '(p) (call d url0 empty)))])
(list c1 c2))
(list (list "1" "1")
(list "2" "1")))
(test-equal? "dir.ss - current-directory"
(let* ([d (mkd (build-path example-servlets "dir.ss"))]
[t0 (first ((sxpath "//p/em/text()") (call d url0 empty)))])
[t0 (simple-xpath* '(p em) (call d url0 empty))])
t0)
(path->string example-servlets))
(test-pred "quiz.ss - send/suspend"
string?
(let* ([d (mkd (build-path example-servlets "quiz.ss"))])
(foldl (lambda (_ k)
(first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0"))))))
(simple-xpath* '(form #:action) (call d k (list (make-binding:form #"answer" #"0")))))
url0
(build-list 7 (lambda (i) i)))))
(test-equal? "clear.ss - current-servlet-continuation-expiration-handler, clear-continuation-table!, send/finish, send/forward"
(let* ([d (mkd (build-path example-servlets "clear.ss"))]
[k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//a/@href/text()") (call d k0 empty)))]
[k0-expired (first ((sxpath "//body/text()") (call d k0 empty)))]
[done (first ((sxpath "//body/text()") (call d k1 empty)))]
[k1-expired (first ((sxpath "//body/text()") (call d k1 empty)))])
[k0 (simple-xpath* '(a #:href) (call d url0 empty))]
[k1 (simple-xpath* '(a #:href) (call d k0 empty))]
[k0-expired (simple-xpath* '(body) (call d k0 empty))]
[done (simple-xpath* '(body) (call d k1 empty))]
[k1-expired (simple-xpath* '(body) (call d k1 empty))])
(list k0-expired
done
k1-expired))

15
collects/tests/web-server/dispatchers/servlet-test-util.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require schemeunit
(planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
mzlib/list
web-server/http
"../util.ss")
@ -21,15 +20,15 @@
t
(let* ([d (mkd p)]
[r0 (call d url0 empty)]
[k0 (first ((sxpath "//form/@action/text()") r0))]
[i0 (first ((sxpath "//form/input/@name/text()") r0))]
[k0 (simple-xpath* '(form #:action) r0)]
[i0 (simple-xpath* '(form input #:name) r0)]
[r1 (call d (format "~a?~a=~a" k0 i0 xs)
(list (make-binding:form (string->bytes/utf-8 i0) xs)))]
[k1 (first ((sxpath "//form/@action/text()") r1))]
[i1 (first ((sxpath "//form/input/@name/text()") r1))]
[k1 (simple-xpath* '(form #:action) r1)]
[i1 (simple-xpath* '(form input #:name) r1)]
[r2 (call d (format "~a?~a=~a" k1 i1 ys)
(list (make-binding:form (string->bytes/utf-8 i1) ys)))]
[n (first ((sxpath "//p/text()") r2))])
[n (simple-xpath* '(p) r2)])
n)
(format "The answer is ~a" (+ x y)))))
@ -37,8 +36,8 @@
(define d (mkd p))
(define (invoke u)
(define sx (call d u empty))
(define ks ((sxpath "//div/div/a/@href/text()") sx))
(values ((sxpath "//div/div/h3/text()") sx)
(define ks (simple-xpath*/list '(div div a #:href) sx))
(values (simple-xpath*/list '(div div h3) sx)
(first ks)
(second ks)))
(test-equal? t

3
collects/tests/web-server/servlet-env-test.ss
View File

@ -1,8 +1,5 @@
#lang scheme/base
(require schemeunit
#;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
ssax:xml->sxml)
#;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
mzlib/etc
mzlib/list
mzlib/pretty

72
collects/tests/web-server/util.ss
View File

@ -1,13 +1,13 @@
#lang scheme
(require (for-syntax scheme/base)
web-server/private/connection-manager
(only-in (planet "ssax.ss" ("lizorkin" "ssax.plt" 2 0))
ssax:xml->sxml)
web-server/http
web-server/private/web-server-structs
net/url
mzlib/pretty
mzlib/list
xml
tests/eli-tester
web-server/private/timer)
(provide make-module-eval
make-eval/mod-path
@ -17,14 +17,76 @@
htxml
call)
(define keyword->symbol (compose string->symbol keyword->string))
(define (simple-xpath/xexpr p x)
(match p
[(list)
(list x)]
[(list-rest (? symbol? s) r)
(match x
[(list-rest (? (curry equal? s)) rs)
(simple-xpath/tag-body r rs)]
[_
empty])]
[_
empty]))
(define (simple-xpath/tag-body p x)
(match p
[(list)
(match x
[(list) empty]
[(list-rest (list (list (? symbol?) (? string?)) ...) rs)
(simple-xpath/tag-body p rs)]
[(? list?)
x]
[_
empty])]
[(list-rest (? symbol?) _)
(match x
[(list-rest (list (list (? symbol?) (? string?)) ...) rs)
(simple-xpath/tag-body p rs)]
[(? list?)
(append-map (curry simple-xpath/xexpr p) x)]
[_
empty])]
[(list (? keyword? k))
(match x
[(list-rest (and attrs (list (list (? symbol?) (? string?)) ...)) rs)
(simple-xpath/attr (keyword->symbol k) attrs)]
[_
empty])]
[_
empty]))
(define (simple-xpath/attr k attrs)
(dict-ref attrs k empty))
(define (simple-xpath*/list p x)
(append (simple-xpath/xexpr p x)
(match x
[(list-rest (list (cons (? symbol?) (? string?)) ...) rs)
(simple-xpath*/list p rs)]
[(? list?)
(append-map (curry simple-xpath*/list p) x)]
[_
empty])))
(define (simple-xpath* p x)
(match (simple-xpath*/list p x)
[(list) #f]
[(list-rest f rs) f]))
(test
(simple-xpath*/list '(p) '(html (body (p "Hey") (p "Bar")))) => (list "Hey" "Bar")
(simple-xpath* '(p) '(html (body (p "Hey")))) => "Hey"
(simple-xpath* '(p #:bar) '(html (body (p ([bar "Zog"]) "Hey")))) => "Zog")
(provide simple-xpath*
simple-xpath*/list)
(define (call d u bs)
(htxml (collect d (make-request #"GET" (string->url u) empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1"))))
(define (htxml bs)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s)
(define sx (ssax:xml->sxml (open-input-bytes s) empty))
#;(pretty-print sx)
sx]
(string->xexpr (bytes->string/utf-8 s))]
[_
(error 'html "Given ~S~n" bs)]))