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

new copy of net tests, split into modules, and using my test macro

Browse Source 
svn: r14143
This commit is contained in:
Eli Barzilay 2009-03-17 11:41:06 +00:00
parent e616818d34
commit b647ea2ae9
7 changed files with 805 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/tests/net/cgi.ss
View File

@ -1,33 +1,21 @@
#lang scheme
(require net/cgi
net/uri-codec
tests/eli-tester)
(define-syntax test-result
(syntax-rules ()
[(test-result expression expected)
(let ([result expression])
(if (equal? result expected)
(display (format "Ok: `~a' evaluated to `~a'.\n"
'expression expected))
(display (format
"Error: `~a' evaluated to `~a', expected `~a'.\n"
'expression result expected))))]))
(void (putenv "REQUEST_METHOD" "GET"))
(require net/cgi net/uri-codec tests/eli-tester)
(define (test-bindings mode query-string)
(parameterize ([current-alist-separator-mode mode])
(putenv "QUERY_STRING" query-string)
(get-bindings)))
(test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3")
=> '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"])
(test-bindings 'amp "key1=value1&key2=value2")
=> '([key1 . "value1"] [key2 . "value2"])
(test-bindings 'amp "key1=value1;key2=value2")
=> '([key1 . "value1;key2=value2"])
(test-bindings 'semi "key1=value1;key2=value2")
=> '([key1 . "value1"] [key2 . "value2"])
(test-bindings 'semi "key1=value1&key2=value2")
=> '([key1 . "value1&key2=value2"]))
(provide tests)
(define (tests)
(putenv "REQUEST_METHOD" "GET")
(test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3")
=> '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"])
(test-bindings 'amp "key1=value1&key2=value2")
=> '([key1 . "value1"] [key2 . "value2"])
(test-bindings 'amp "key1=value1;key2=value2")
=> '([key1 . "value1;key2=value2"])
(test-bindings 'semi "key1=value1;key2=value2")
=> '([key1 . "value1"] [key2 . "value2"])
(test-bindings 'semi "key1=value1&key2=value2")
=> '([key1 . "value1&key2=value2"])))

84
collects/tests/net/cookie.ss Normal file
View File

@ -0,0 +1,84 @@
#lang scheme
(require net/cookie tests/eli-tester)
;; cookie tests --- JBM, 2006-12-01
(provide tests)
(define (tests)
;; cookie-test : (cookie -> cookie) string -> test
(define (cookie-test fn expected)
(test (print-cookie (fn (set-cookie "a" "b"))) => expected))
;; RC = "reverse curry"
(define (RC f arg2) (λ (arg1) (f arg1 arg2)))
;; o = compose
(define-syntax o
(syntax-rules ()
[(o f) f]
[(o f g h ...) (λ (x) (o/* x f g h ...))]))
(define-syntax o/*
(syntax-rules ()
[(o/* x) x]
[(o/* x f g ...) (f (o/* x g ...))]))
(define (tests)
;; test the most basic functionality
(cookie-test (λ (x) x) "a=b; Version=1")
;; test each modifier individually
(cookie-test (RC cookie:add-comment "set+a+to+b")
"a=b; Comment=set+a+to+b; Version=1")
(cookie-test (RC cookie:add-comment "a comment with spaces")
"a=b; Comment=\"a comment with spaces\"; Version=1")
(cookie-test (RC cookie:add-comment "the \"risks\" involved in waking")
"a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1")
(cookie-test (RC cookie:add-comment "\"already formatted\"")
"a=b; Comment=\"already formatted\"; Version=1")
(cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"")
"a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1")
(cookie-test (RC cookie:add-comment "contains;semicolon")
"a=b; Comment=\"contains;semicolon\"; Version=1")
(cookie-test (RC cookie:add-domain ".example.net")
"a=b; Domain=.example.net; Version=1")
(cookie-test (RC cookie:add-max-age 100)
"a=b; Max-Age=100; Version=1")
(cookie-test (RC cookie:add-path "/whatever/wherever/")
"a=b; Path=\"/whatever/wherever/\"; Version=1")
(cookie-test (RC cookie:add-path "a+path")
"a=b; Path=a+path; Version=1")
(cookie-test (RC cookie:add-path "\"/already/quoted/\"")
"a=b; Path=\"/already/quoted/\"; Version=1")
(cookie-test (RC cookie:secure #t)
"a=b; Secure; Version=1")
(cookie-test (RC cookie:secure #f)
"a=b; Version=1")
(cookie-test (RC cookie:version 12)
"a=b; Version=12")
;; test combinations
(cookie-test (o (RC cookie:add-comment "set+a+to+b")
(RC cookie:add-domain ".example.net"))
"a=b; Comment=set+a+to+b; Domain=.example.net; Version=1")
(cookie-test (o (RC cookie:add-max-age 300)
(RC cookie:secure #t))
"a=b; Max-Age=300; Secure; Version=1")
(cookie-test (o (RC cookie:add-path "/whatever/wherever/")
(RC cookie:version 10)
(RC cookie:add-max-age 20))
"a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10")
;; test error cases
(let ()
(define-syntax cookie-error-test
(syntax-rules ()
[(cookie-error-test e)
(test (e (set-cookie "a" "b")) =error> cookie-error?)]))
(cookie-error-test (RC cookie:add-comment "illegal character #\000"))
(cookie-error-test (RC cookie:add-max-age -10))
(cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com"))
(cookie-error-test (RC cookie:add-domain "bad domain.com"))
(cookie-error-test (RC cookie:add-domain ".bad-domain;com")))
)
(test do (tests)))

109
collects/tests/net/encoders.ss Normal file
View File

@ -0,0 +1,109 @@
#lang scheme
(require net/base64 net/qp tests/eli-tester)
(define tricky-strings
(let ([dir (collection-path "tests" "mzscheme")])
(list (make-bytes 200 32)
(make-bytes 200 9)
(make-bytes 200 (char->integer #\x))
(make-bytes 201 (char->integer #\x))
(make-bytes 202 (char->integer #\x))
(make-bytes 203 (char->integer #\x))
(make-bytes 204 (char->integer #\x))
(list->bytes (for/list ([i (in-range 256)]) i))
;; Something that doesn't end with a LF:
(bytes-append (with-input-from-file (build-path dir "net.ss")
(lambda () (read-bytes 500)))
#"xxx")
;; CRLF:
(regexp-replace #rx#"\r?\n"
(with-input-from-file (build-path dir "net.ss")
(lambda () (read-bytes 500)))
#"\r\n"))))
(define (check-same encode decode port line-rx max-w)
(let ([p (open-output-bytes)])
(copy-port port p)
(let ([bytes (get-output-bytes p)]
[r (open-output-bytes)])
(encode (open-input-bytes bytes) r)
(let ([p (open-input-bytes (get-output-bytes r))])
(let loop ()
(let ([l (read-bytes-line p 'any)])
(unless (eof-object? l)
(test ; #:failure-message (format "line too long; ~s" encode)
(<= (bytes-length l) max-w))
(let ([m (regexp-match-positions line-rx l)])
(test ; #:failure-message (format "bad line; ~s" encode)
(and m (= (bytes-length l) (cdar m)))))
(loop))))
(let ([q (open-output-bytes)])
(decode (open-input-bytes (get-output-bytes r)) q)
(unless (equal? (get-output-bytes q) bytes)
(with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate)
(with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate)
(with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate)
(error 'decode "failed")))))))
(define ((check-same-file encode decode line-rx max-w) file)
(call-with-input-file file
(lambda (p) (check-same encode decode p line-rx max-w))))
(define (check-same-all encode decode line-rx max-w)
(for-each (lambda (tricky-string)
(check-same encode decode
(open-input-bytes tricky-string)
line-rx max-w))
tricky-strings)
(let* ([dir (collection-path "tests" "mzscheme")]
[files (filter-map
(lambda (f)
;; check 1/4 of the files, randomly
(let ([p (build-path dir f)])
(and (zero? (random 4))
(not (regexp-match #rx"^flat.*\\.ss$"
(path-element->string f)))
(file-exists? p)
p)))
(directory-list dir))])
(for-each (check-same-file encode decode line-rx max-w) files)))
(provide tests)
(define (tests)
(test
do (check-same-all (lambda (i o) (qp-encode-stream i o))
qp-decode-stream
#rx#"^(|[\t \41-\176]*[\41-\176]+)$"
76)
do (check-same-all base64-encode-stream
base64-decode-stream
#rx#"^[0-9a-zA-Z+=/]*$"
72)))
#|
Use this to compare base64 encode/decode against the unix utilities
(require net/base64 scheme/system)
(define (base64-encode* bstr)
(let ([o (open-output-bytes)])
(parameterize ([current-output-port o]
[current-input-port (open-input-bytes bstr)])
(system "base64-encode"))
(let* ([o (get-output-bytes o)]
[o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")]
[o (regexp-replace* #rx#"\r?\n" o #"\r\n")])
o)))
(define (base64-decode* bstr)
(let ([o (open-output-bytes)])
(parameterize ([current-output-port o]
[current-input-port (open-input-bytes bstr)])
(system "base64-decode"))
(get-output-bytes o)))
(define (check-base64-encode bstr)
(equal? (base64-encode bstr) (base64-encode* bstr)))
(define (check-base64-decode bstr)
(equal? (base64-decode bstr) (base64-decode* bstr)))
(define (check-base64-both bstr)
(let ([en (base64-encode bstr)])
(and (equal? en (base64-encode* bstr))
(equal? (base64-decode en) (base64-decode* en)))))
|#

93
collects/tests/net/head.ss Normal file
View File

@ -0,0 +1,93 @@
#lang scheme
(require net/head tests/eli-tester)
;; a few tests of head.ss -- JBC, 2006-07-31
(provide tests)
(define (tests)
(define test-header
(string-append "From: abc\r\nTo: field is\r\n continued\r\n"
"Another: zoo\r\n continued\r\n\r\n"))
(define test-header/bytes
(bytes-append #"From: abc\r\nTo: field is\r\n continued\r\n"
#"Another: zoo\r\n continued\r\n\r\n"))
(test
(validate-header "From: me@here.net\r\n\r\n")
(validate-header #"From: me@here.net\r\n\r\n")
(validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n")
(validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n")
(validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n")
=error> "missing ending CRLF"
(validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n")
=error> "missing ending CRLF"
(validate-header "From: a\r\nnocolon inthisline\r\n\r\n")
=error> "ill-formed header"
(validate-header #"From: a\r\nnocolon inthisline\r\n\r\n")
=error> "ill-formed header"
(validate-header "From: a\r\nMissingReturn: och\n\r\n")
=error> "missing ending CRLF"
(validate-header #"From: a\r\nMissingReturn: och\n\r\n")
=error> "missing ending CRLF"
(validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n")
=error> "ill-formed header"
(validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n")
=error> "ill-formed header"
(extract-field "From" test-header)
=> "abc"
(extract-field #"From" test-header/bytes)
=> #"abc"
(extract-field "To" test-header)
=> "field is\r\n continued"
(extract-field #"To" test-header/bytes)
=> #"field is\r\n continued"
(extract-field "Another" test-header)
=> "zoo\r\n continued"
(extract-field #"Another" test-header/bytes)
=> #"zoo\r\n continued"
(replace-field "From" "def" test-header)
=> "From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field #"From" #"def" test-header/bytes)
=> #"From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field "From" #f test-header)
=> "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field #"From" #f test-header/bytes)
=> #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field "To" "qrs" test-header)
=> "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field #"To" #"qrs" test-header/bytes)
=> #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field "To" #f test-header)
=> "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field #"To" #f test-header/bytes)
=> #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n"
(replace-field "Another" "abc\r\n def" test-header)
=> "From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n"
(replace-field #"Another" #"abc\r\n def" test-header/bytes)
=> #"From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n"
(replace-field "Another" #f test-header)
=> "From: abc\r\nTo: field is\r\n continued\r\n\r\n"
(replace-field #"Another" #f test-header/bytes)
=> #"From: abc\r\nTo: field is\r\n continued\r\n\r\n"
(remove-field "To" test-header)
=> "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n"
(remove-field #"To" test-header/bytes)
=> #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n"
(extract-all-fields test-header)
=> `(("From" . "abc") ("To" . "field is\r\n continued") ("Another" . "zoo\r\n continued"))
(extract-all-fields test-header/bytes)
=> `((#"From" . #"abc") (#"To" . #"field is\r\n continued") (#"Another" . #"zoo\r\n continued"))
(append-headers test-header "Athird: data\r\n\r\n")
=> "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n"
(append-headers test-header/bytes #"Athird: data\r\n\r\n")
=> #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n"
))

18
collects/tests/net/main.ss
View File

@ -1,3 +1,19 @@
#lang scheme/base
(require "cgi.ss")
(require tests/eli-tester
(prefix-in ucodec: "uri-codec.ss")
(prefix-in url: "url.ss")
(prefix-in cgi: "cgi.ss")
(prefix-in head: "head.ss")
(prefix-in cookie: "cookie.ss")
(prefix-in encoders: "encoders.ss"))
(define (tests)
(test do (begin (url:tests)
(ucodec:tests)
(cgi:tests)
(head:tests)
(cookie:tests)
(encoders:tests))))
(tests)

131
collects/tests/net/uri-codec.ss Normal file
View File

@ -0,0 +1,131 @@
#lang scheme
(require net/uri-codec tests/eli-tester)
(provide tests)
(define (tests)
(define sepmode current-alist-separator-mode)
(test (uri-decode "%Pq") => "%Pq"
(uri-decode "%P") => "%P"
(alist->form-urlencoded '([a . "hel+lo \u7238"]))
=> "a=hel%2Blo+%E7%88%B8"
(form-urlencoded->alist
(alist->form-urlencoded '([a . "hel+lo \u7238"])))
=> '([a . "hel+lo \u7238"])
(alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"]))
=> "a=hel%2Blo&b=good-bye"
do (let ([alist '([a . "hel+lo"] [b . "good-bye"])]
[ampstr "a=hel%2Blo&b=good-bye"]
[semistr "a=hel%2Blo;b=good-bye"])
(define (alist<->str mode str)
(parameterize ([sepmode (or mode (sepmode))])
(test (alist->form-urlencoded alist) => str
(form-urlencoded->alist str) => alist)))
(alist<->str #f ampstr) ; test the default
(alist<->str 'amp ampstr)
(alist<->str 'amp-or-semi ampstr)
(alist<->str 'semi semistr)
(alist<->str 'semi-or-amp semistr))
(form-urlencoded->alist "x=foo&y=bar;z=baz")
=> '([x . "foo"] [y . "bar"] [z . "baz"])
(parameterize ([sepmode 'semi])
(form-urlencoded->alist
(parameterize ([sepmode 'amp])
(alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"])))))
=> '([a . "hel+lo&b=good-bye"])
(parameterize ([sepmode 'amp])
(form-urlencoded->alist
(parameterize ([sepmode 'semi])
(alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"])))))
=> '([a . "hel+lo;b=good-bye"])
(alist->form-urlencoded '([aNt . "Hi"]))
=> "aNt=Hi"
(form-urlencoded->alist (alist->form-urlencoded '([aNt . "Hi"])))
=> '([aNt . "Hi"])
(alist->form-urlencoded (form-urlencoded->alist "aNt=Hi"))
=> "aNt=Hi"
(current-alist-separator-mode) => 'amp-or-semi
(current-alist-separator-mode 'bad) =error> "expected argument of type"
;; Test all ASCII chars
do
(let ([p (for/list ([n (in-range 128)])
(let ([s (string (char-downcase (integer->char n)))])
(cons (string->symbol s) s)))])
(test (form-urlencoded->alist (alist->form-urlencoded p)) => p)
(let ([l (apply string-append (map cdr p))])
(test (uri-decode (uri-encode l)) => l)))
do (noels-tests)
(uri-userinfo-encode "hello") => "hello"
(uri-userinfo-encode "hello there") => "hello%20there"
(uri-userinfo-encode "hello:there") => "hello:there"
(uri-userinfo-decode "hello") => "hello"
(uri-userinfo-decode "hello%20there") => "hello there"
(uri-userinfo-decode "hello:there") => "hello:there"
))
;; tests adapted from Noel Welsh's original test suite
(define (noels-tests)
(define (pad2 str)
(if (= (string-length str) 1) (string-append "0" str) str))
(define (%hex n)
(string-append "%" (pad2 (string-downcase (number->string n 16)))))
(define (%HEX n)
(string-append "%" (pad2 (string-upcase (number->string n 16)))))
(test
(uri-encode "hello") => "hello"
(uri-encode "hello there") => "hello%20there"
do
(for ([code (in-range 128)])
(if (or (member code '(33 39 40 41 42 45 46 95 126))
(<= 48 code 57) ; 0-9
(<= 65 code 90) ; A-Z
(<= 97 code 122)) ; a-z
(test (uri-encode (string (integer->char code)))
=> (string (integer->char code)))
(test (uri-encode (string (integer->char code)))
=> (%HEX code))))
(alist->form-urlencoded '()) => ""
(alist->form-urlencoded '([key . "hello there"]))
=> "key=hello+there"
(alist->form-urlencoded '([key1 . "hi"] [key2 . "hello"]))
=> "key1=hi&key2=hello"
(alist->form-urlencoded '([key1 . "hello there"]))
=> "key1=hello+there"
(uri-decode "hello")
=> "hello"
(uri-decode "hello%20there")
=> "hello there"
;; these were going from 0 to 255 in Noel's original test suite.
;; Those fail here, however.
do (for ([code (in-range 128)])
(test (uri-decode (%HEX code)) => (string (integer->char code))
(uri-decode (%hex code)) => (string (integer->char code))
(uri-decode (string (integer->char code)))
=> (string (integer->char code))))
;; form-urlencoded->alist
(form-urlencoded->alist "") => '()
(form-urlencoded->alist "key=value")
=> '([key . "value"])
(form-urlencoded->alist "key=hello+there")
=> '([key . "hello there"])
(form-urlencoded->alist "key=a%20value")
=> '([key . "a value"])
(form-urlencoded->alist "key")
=> '([key . #f])
(form-urlencoded->alist "key1=value+1&key2=value+2")
=> '([key1 . "value 1"] [key2 . "value 2"])
))

357
collects/tests/net/url.ss Normal file
View File

@ -0,0 +1,357 @@
#lang scheme
(require net/url tests/eli-tester
(only-in net/uri-codec current-alist-separator-mode))
(define (url->vec url)
(vector
(url-scheme url)
(url-user url)
(url-host url)
(url-port url)
(url-path-absolute? url)
(map (lambda (x)
(list->vector (cons (path/param-path x) (path/param-param x))))
(url-path url))
(url-query url)
(url-fragment url)))
(define (vec->url vec)
(make-url
(vector-ref vec 0)
(vector-ref vec 1)
(vector-ref vec 2)
(vector-ref vec 3)
(vector-ref vec 4)
(map (lambda (x)
(let ([lst (vector->list x)])
(make-path/param (car lst) (cdr lst))))
(vector-ref vec 5))
(vector-ref vec 6)
(vector-ref vec 7)))
(define (string->url/vec str) (url->vec (string->url str)))
(define (url/vec->string vec) (url->string (vec->url vec)))
(define (test-s->u vec str)
(test (string->url/vec str) => vec
(url/vec->string vec) => str))
(define (test-c-u/r expected base relative)
(define (combine-url/relative-vec x y)
(url->vec (combine-url/relative (vec->url x) y)))
(define (->vec x) (url->vec (if (string? x) (string->url x) x)))
(test (combine-url/relative-vec (->vec base) relative)
=> (->vec expected)))
(define (run-tests)
(test
;; Test the current-proxy-servers parameter can be set
(parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))])
(current-proxy-servers))
=> '(("http" "proxy.com" 3128)))
(test-s->u #(#f #f #f #f #t (#("")) () #f)
"/")
(test-s->u #(#f #f #f #f #f () () #f)
"")
(test-s->u #("http" #f #f #f #t (#("")) () #f)
"http:/")
(test-s->u #("http" #f "" #f #t (#("")) () #f)
"http:///")
(test-s->u #("http" #f "www.drscheme.org" #f #f () () #f)
"http://www.drscheme.org")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f)
"http://www.drscheme.org/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f)
"http://www.drscheme.org/a/b/c")
(test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f)
"http://robby@www.drscheme.org/a/b/c")
(test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f)
"http://www.drscheme.org:8080/a/b/c")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe")
"http://www.drscheme.org/a/b/c#joe")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f)
"http://www.drscheme.org/a/b/c?tim=")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) "joe")
"http://www.drscheme.org/a/b/c?tim=#joe")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "tim")) "joe")
"http://www.drscheme.org/a/b/c?tim=tim#joe")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom")) "joe")
"http://www.drscheme.org/a/b/c?tam=tom#joe")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe")
"http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")
(parameterize ([current-alist-separator-mode 'semi])
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe")
"http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe"))
(parameterize ([current-alist-separator-mode 'amp])
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe")
"http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe"))
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f)
"http://www.drscheme.org/a/b/c;b")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f)
"http://www.drscheme.org/a;x/b/c;b")
;; test unquoting for %
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e")
"http://www.drscheme.org/a/b/c?ti%23m=#jo%20e")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f)
"http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20")
(test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f)
"http://robb%20y@www.drscheme.org/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f)
"http://www.drscheme.org/%25a/b%2F/c")
(test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f)
"http://robby:password@www.drscheme.org/")
(test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/")
;; test the characters that need to be encoded in paths vs those that do not need to
;; be encoded in paths
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f)
"http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f)
"http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def")
(test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f)
"http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;")
;; test other scheme identifiers
(test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f)
"blah://www.foo.com/")
(test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f)
"blah99://www.foo.com/")
(test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f)
"blah+://www.foo.com/")
(test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f)
"a+b-c456.d://www.foo.com/")
;; a colon and other junk (`sub-delims') can appear in usernames
(test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f)
string->url/vec
"http://x:!$&'()*+,;=y@www.drscheme.org/a")
;; a colon and atsign can appear in absolute paths
(test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f)
"/x:@y/z")
;; and in relative paths as long as it's not in the first element
(test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f)
"x/y:@z")
;; test bad schemes
(test
(string->url "://www.foo.com/") =error> url-exception?
(string->url "9://www.foo.com/") =error> url-exception?
(string->url "9a://www.foo.com/") =error> url-exception?
(string->url "a*b://www.foo.com/") =error> url-exception?
(string->url "a b://www.foo.com/") =error> url-exception?)
;; test file: urls
(test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f)
"file:///abc/def.html")
(test (url->string (string->url "file:///abc/def.html"))
=> "file:///abc/def.html")
(parameterize ([file-url-path-convention-type 'unix])
(test (url->string (string->url "file://a/b"))
=> "file://a/b")
(test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f)
"file://localhost/abc/def.html"))
;; test files: urls with colons, and the different parsing on Windows
(test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f)
"file://localhost:123/abc/def.html")
(parameterize ([file-url-path-convention-type 'unix])
;; different parse for file://foo:/...
(test (string->url/vec "file://foo:/abc/def.html")
=> #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f)))
(parameterize ([file-url-path-convention-type 'windows])
(test (string->url/vec "file://foo:/abc/def.html")
=> #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f)
(string->url/vec "file://c:/abc/def.html")
=> #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f)
(string->url/vec "file:\\\\d\\c\\abc\\def.html")
=> #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f)))
(parameterize ([file-url-path-convention-type 'unix])
;; but no effect on http://foo:/...
(test (string->url/vec "http://foo:/abc/def.html")
=> #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f)))
(parameterize ([file-url-path-convention-type 'windows])
(test (string->url/vec "http://foo:/abc/def.html")
=> #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f)))
(test (url->string (path->url (bytes->path #"c:\\a\\b" 'windows)))
=> "file:///c:/a/b"
(url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)))
=> "file:///c:/a/b")
(test
(path->bytes (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix))
=> #"/a/b/c"
(path->bytes (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix))
=> #"a/b/c"
(path->bytes (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows))
=> #"c:\\a\\b"
(path->bytes (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows))
=> #"a\\b"
(path->bytes (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows))
=> #"\\\\d\\c\\a"
(path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows))
=> #"c:\\a\\b"
(path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows))
=> #"\\\\d\\c\\a\\b"
(path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows))
=> #"\\\\?\\c:\\a/x\\b"
(path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows))
=> #"\\\\?\\UNC\\d\\c\\a/x\\b")
;; see PR8809 (value-less keys in the query part)
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f)
"http://foo.bar/baz?ugh")
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "")) #f)
"http://foo.bar/baz?ugh=")
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f)
"http://foo.bar/baz?ugh&x=y&1=2")
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "") (x . "y") (|1| . "2")) #f)
"http://foo.bar/baz?ugh=&x=y&1=2")
(parameterize ([current-alist-separator-mode 'amp])
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f)
"http://foo.bar/baz?ugh&x=y&1=2"))
(parameterize ([current-alist-separator-mode 'semi])
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f)
"http://foo.bar/baz?ugh;x=y;1=2"))
;; test case sensitivity
(test (string->url/vec
"HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")
=> #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY"))
(test-s->u #("mailto" #f #f #f #f (#("robby@plt-scheme.org")) () #f)
"mailto:robby@plt-scheme.org")
(test (string->url/vec "http://www.drscheme.org?bar=馨慧")
#("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f))
(test (string->url/vec "http://www.drscheme.org?bár=é")
=> #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f))
(test-c-u/r "http://www.drscheme.org"
(make-url #f #f #f #f #f '() '() #f)
"http://www.drscheme.org")
(test-c-u/r "http://www.drscheme.org"
"http://www.drscheme.org"
"")
(test-c-u/r "http://www.mzscheme.org"
"http://www.drscheme.org/"
"http://www.mzscheme.org")
(test-c-u/r "http://www.drscheme.org/index.html"
"http://www.drscheme.org/"
"index.html")
(test-c-u/r "http://www.drscheme.org/index.html"
"http://www.drscheme.org/"
"/index.html")
(test-c-u/r "http://www.drscheme.org/index.html"
"http://www.drscheme.org/a/b/c/"
"/index.html")
(test-c-u/r "http://www.drscheme.org/a/b/index.html"
"http://www.drscheme.org/a/b/c"
"index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/index.html"
"http://www.drscheme.org/a/b/c/"
"index.html")
(test-c-u/r "http://www.drscheme.org/a/b/d/index.html"
"http://www.drscheme.org/a/b/c"
"d/index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html"
"http://www.drscheme.org/a/b/c/"
"d/index.html")
(test-c-u/r "http://www.drscheme.org/a/b/index.html"
"http://www.drscheme.org/a/b/c/"
"../index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/index.html"
"http://www.drscheme.org/a/b/c/"
"./index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/%2e%2e/index.html"
"http://www.drscheme.org/a/b/c/"
"%2e%2e/index.html")
(test-c-u/r "http://www.drscheme.org/a/index.html"
"http://www.drscheme.org/a/b/../c/"
"../index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html"
"http://www.drscheme.org/a/b/c/d/index.html#ghijkl"
"index.html")
(test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html#abcdef"
"http://www.drscheme.org/a/b/c/d/index.html#ghijkl"
"#abcdef")
(test-c-u/r "file:///a/b/c/d/index.html"
"file:///a/b/c/"
"d/index.html")
(test-c-u/r "file:///a/b/d/index.html"
"file:///a/b/c"
"d/index.html")
;; tests from rfc 3986
(for-each
(λ (line) (test-c-u/r (caddr line) "http://a/b/c/d;p?q" (car line)))
'(("g:h" = "g:h")
("g" = "http://a/b/c/g")
("./g" = "http://a/b/c/g")
("g/" = "http://a/b/c/g/")
("/g" = "http://a/g")
("//g" = "http://g")
("?y" = "http://a/b/c/d;p?y")
("g?y" = "http://a/b/c/g?y")
("#s" = "http://a/b/c/d;p?q#s")
("g#s" = "http://a/b/c/g#s")
("g?y#s" = "http://a/b/c/g?y#s")
(";x" = "http://a/b/c/;x")
("g;x" = "http://a/b/c/g;x")
("g;x?y#s" = "http://a/b/c/g;x?y#s")
("" = "http://a/b/c/d;p?q")
("." = "http://a/b/c/")
("./" = "http://a/b/c/")
(".." = "http://a/b/")
("../" = "http://a/b/")
("../g" = "http://a/b/g")
("../.." = "http://a/")
("../../" = "http://a/")
("../../g" = "http://a/g")
;; abnormal examples follow
("../../../g" = "http://a/g")
("../../../../g" = "http://a/g")
("/./g" = "http://a/g")
("/../g" = "http://a/g")
("g." = "http://a/b/c/g.")
(".g" = "http://a/b/c/.g")
("g.." = "http://a/b/c/g..")
("..g" = "http://a/b/c/..g")
("./../g" = "http://a/b/g")
("./g/." = "http://a/b/c/g/")
("g/./h" = "http://a/b/c/g/h")
("g/../h" = "http://a/b/c/h")
("g;x=1/./y" = "http://a/b/c/g;x=1/y")
("g;x=1/../y" = "http://a/b/c/y")
("g?y/./x" = "http://a/b/c/g?y/./x")
("g?y/../x" = "http://a/b/c/g?y/../x")
("g#s/./x" = "http://a/b/c/g#s/./x")
("g#s/../x" = "http://a/b/c/g#s/../x")
("http:g" = "http:g") ; for strict parsers
))
)
(provide tests)
(define (tests) (test do (run-tests)))