diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 8475c099e9..4e63c38897 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -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))) diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 9002d9de3b..ab8121b174 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -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)) diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss index 420c0bcba4..4fe236c5cf 100644 --- a/collects/tests/web-server/dispatchers/servlet-test-util.ss +++ b/collects/tests/web-server/dispatchers/servlet-test-util.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require schemeunit - (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0)) +(require schemeunit 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 diff --git a/collects/tests/web-server/servlet-env-test.ss b/collects/tests/web-server/servlet-env-test.ss index 72193dcfa2..02ddf1496a 100644 --- a/collects/tests/web-server/servlet-env-test.ss +++ b/collects/tests/web-server/servlet-env-test.ss @@ -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 diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss index caa93a5b9c..a91ba7e682 100644 --- a/collects/tests/web-server/util.ss +++ b/collects/tests/web-server/util.ss @@ -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)]))