diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 7b72211105..5d804c56e0 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -3,657 +3,6 @@ (Section 'net) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; url.ss tests -;; - -(require net/url - net/uri-codec - mzlib/string - ) - -(test "%Pq" uri-decode "%Pq") -(test "%P" uri-decode "%P") -(test "a=hel%2Blo+%E7%88%B8" alist->form-urlencoded '((a . "hel+lo \u7238"))) -(test '((a . "hel+lo \u7238")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo \u7238")))) -(test "a=hel%2Blo&b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))) -(let* ([alist '((a . "hel+lo") (b . "good-bye"))] - [ampstr "a=hel%2Blo&b=good-bye"] - [semistr "a=hel%2Blo;b=good-bye"]) - (define (test:alist<->str mode str) - (parameterize ([current-alist-separator-mode - (or mode (current-alist-separator-mode))]) - (test str alist->form-urlencoded alist) - (test alist form-urlencoded->alist str))) - (test:alist<->str #f ampstr) ; the default - (test:alist<->str 'amp ampstr) - (test:alist<->str 'amp-or-semi ampstr) - (test:alist<->str 'semi semistr) - (test:alist<->str 'semi-or-amp semistr)) -(test '((x . "foo") (y . "bar") (z . "baz")) - form-urlencoded->alist "x=foo&y=bar;z=baz") -(parameterize ([current-alist-separator-mode 'semi]) - (test '((a . "hel+lo&b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'amp]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(parameterize ([current-alist-separator-mode 'amp]) - (test '((a . "hel+lo;b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'semi]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(test "aNt=Hi" alist->form-urlencoded '((aNt . "Hi"))) -(test '((aNt . "Hi")) form-urlencoded->alist (alist->form-urlencoded '((aNt . "Hi")))) -(test "aNt=Hi" alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) - -(test 'amp-or-semi current-alist-separator-mode) -(err/rt-test (current-alist-separator-mode 'bad)) - -;; Test the current-proxy-servers parameter can be set -(parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) - (test '(("http" "proxy.com" 3128)) current-proxy-servers)) - -(let ([with-censor (load-relative "censor.ss")]) - (with-censor - (lambda () - ;; Test all ASCII chars - (let ([p (let loop ([n 0]) - (if (= n 128) - null - (let ([s (string (char-downcase (integer->char n)))]) - (cons (cons (string->symbol s) s) - (loop (add1 n))))))]) - (test p form-urlencoded->alist (alist->form-urlencoded p)) - (let ([l (apply string-append (map cdr p))]) - (test l uri-decode (uri-encode l))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; tests adapted from Noel Welsh's original test suite -;; - -(let () - (define-syntax (for stx) - (syntax-case stx (code) - [(_ (i from to) e) - (and (identifier? (syntax code)) - (number? (syntax-e (syntax from))) - (number? (syntax-e (syntax to)))) - (syntax (let loop ([i from]) - e - (unless (= i to) - (loop (+ i 1)))))])) - - (test "hello" uri-encode "hello") - (test "hello%20there" uri-encode "hello there") - - (let ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str)))) - (for (code 0 127) - (if (or (= code 45) (= code 33) (= code 95) - (= code 46) (= code 126) (= code 42) - (= code 39) (= code 40) (= code 41) - (and (<= 48 code) (<= code 57)) ; 0-9 - (and (<= 65 code) (<= code 90)) ; A-Z - (and (<= 97 code) (<= code 122))) ; a-z - (test (string (integer->char code)) uri-encode (string (integer->char code))) - (test (string-append "%" (pad (string-upcase (number->string code 16)))) - uri-encode - (string (integer->char code)))))) - - (test "" alist->form-urlencoded '()) - (test "key=hello+there" alist->form-urlencoded '((key . "hello there"))) - (test "key1=hi&key2=hello" alist->form-urlencoded '((key1 . "hi") (key2 . "hello"))) - (test "key1=hello+there" alist->form-urlencoded '((key1 . "hello there"))) - - (test "hello" uri-decode "hello") - (test "hello there" uri-decode "hello%20there") - - (let* ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str))) - (uppercase (lambda (str) - (string-uppercase! str) - str)) - (lowercase (lambda (str) - (string-lowercase! str) - str)) - (hexcode (lambda (code) - (string-append "%" - (pad (number->string code 16)))))) - - ;; each of the next three of these were going from 0 to 255 in Noel's - ;; original test suite. Those fail here, however. - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (uppercase (hexcode code)))) - (for (code 0 127) - (test (string (integer->char code)) uri-decode (lowercase (hexcode code))))) - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (string (integer->char code)))) - - ;; form-urlencoded->alist - (test '() form-urlencoded->alist "") - (test '((key . "value")) form-urlencoded->alist "key=value") - (test '((key . "hello there")) form-urlencoded->alist "key=hello+there") - (test '((key . "a value")) form-urlencoded->alist "key=a%20value") - (test '((key . #f)) form-urlencoded->alist "key") - (test '((key1 . "value 1") (key2 . "value 2")) form-urlencoded->alist "key1=value+1&key2=value+2")) - -;; -;; end Noel's original tests -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(test "hello" uri-userinfo-encode "hello") -(test "hello%20there" uri-userinfo-encode "hello there") -(test "hello:there" uri-userinfo-encode "hello:there") -(test "hello" uri-userinfo-decode "hello") -(test "hello there" uri-userinfo-decode "hello%20there") -(test "hello:there" uri-userinfo-decode "hello:there") - - -(let () - (define (test-s->u vec str) - (test vec string->url/vec str) - (test str url/vec->string vec)) - - (define (string->url/vec str) (url->vec (string->url str))) - (define (url/vec->string vec) (url->string (vec->url vec))) - - (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 (->vec expected) combine-url/relative-vec (->vec base) relative)) - - (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 (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))) - - (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 - (err/rt-test (string->url "://www.foo.com/") url-exception?) - (err/rt-test (string->url "9://www.foo.com/") url-exception?) - (err/rt-test (string->url "9a://www.foo.com/") url-exception?) - (err/rt-test (string->url "a*b://www.foo.com/") url-exception?) - (err/rt-test (string->url "a b://www.foo.com/") url-exception?) - - ;; test file: urls - (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) - "file:///abc/def.html") - (test "file:///abc/def.html" url->string (string->url "file:///abc/def.html")) - (parameterize ([file-url-path-convention-type 'unix]) - (test "file://a/b" url->string (string->url "file://a/b"))) - - (parameterize ([file-url-path-convention-type 'unix]) - (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 #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html") - (test #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) - string->url/vec - "file://c:/abc/def.html") - (test #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f) - string->url/vec - "file:\\\\d\\c\\abc\\def.html")) - - (parameterize ([file-url-path-convention-type 'unix]) - ;; but no effect on http://foo:/... - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows))) - - (test #"/a/b/c" path->bytes - (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix)) - (test #"a/b/c" path->bytes - (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows)) - (test #"a\\b" path->bytes - (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a" path->bytes - (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows)) - (test #"\\\\?\\c:\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows)) - (test #"\\\\?\\UNC\\d\\c\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows)) - - ;; 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 #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY") - string->url/vec - "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/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 #("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f) - string->url/vec - "http://www.drscheme.org?bar=馨慧") - - (test #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f) - string->url/vec - "http://www.drscheme.org?bár=é") - - (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 - - )) - - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; a few tests of head.ss -- JBC, 2006-07-31 -;; - -(require net/head) - -(test (void) validate-header "From: me@here.net\r\n\r\n") -(test (void) validate-header #"From: me@here.net\r\n\r\n") -(test (void) validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(test (void) validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(err/rt-test (validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) - -(define test-header "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") -(define test-header/bytes #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") - -(test "abc" extract-field "From" test-header) -(test #"abc" extract-field #"From" test-header/bytes) -(test "field is\r\n continued" extract-field "To" test-header) -(test #"field is\r\n continued" extract-field #"To" test-header/bytes) -(test "zoo\r\n continued" extract-field "Another" test-header) -(test #"zoo\r\n continued" extract-field #"Another" test-header/bytes) - -(test "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) -(test #"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) -(test "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "From" #f test-header) -(test #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"From" #f test-header/bytes) - -(test "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" "qrs" test-header) -(test #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #"qrs" test-header/bytes) -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" #f test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #f test-header/bytes) - -(test "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) -(test #"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) -(test "From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field "Another" #f test-header) -(test #"From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field #"Another" #f test-header/bytes) - -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field "To" test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field #"To" test-header/bytes) - -(test `(("From" . "abc") - ("To" . "field is\r\n continued") - ("Another" . "zoo\r\n continued")) - extract-all-fields test-header) -(test `((#"From" . #"abc") - (#"To" . #"field is\r\n continued") - (#"Another" . #"zoo\r\n continued")) - extract-all-fields test-header/bytes) - -(test "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 "Athird: data\r\n\r\n") -(test #"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") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; cookie tests --- JBM, 2006-12-01 - -(require net/cookie) - -;; cookie-test : (cookie -> cookie) string -> test -(define (cookie-test fn expected) - (test expected - (λ (c) (print-cookie (fn c))) - (set-cookie "a" "b"))) - -;; 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 ...))])) - -;; 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 -(define-syntax cookie-error-test - (syntax-rules () - [(cookie-error-test e) - (thunk-error-test (λ () (e (set-cookie "a" "b"))) #'e 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")) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; other net tests @@ -663,115 +12,4 @@ net/qp mzlib/port) -(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 - (let loop ([i 0]) - (if (= i 256) - null - (cons i (loop (add1 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) - (unless (<= (bytes-length l) max-w) - (test encode "line too long" l)) - (let ([m (regexp-match-positions line-rx l)]) - (unless (and m (= (bytes-length l) (cdar m))) - (test encode 'bad-line l))) - (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) - ;; This "test" is really just a progress report: - (test #t list? (list file encode)) - (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/3 of the files, randomly - (let ([p (build-path dir f)]) - (and (zero? (random 3)) - (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))) - -(check-same-all (lambda (i o) (qp-encode-stream i o)) - qp-decode-stream - #rx#"^(|[\t \41-\176]*[\41-\176]+)$" - 76) - -(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))))) -|# - (report-errs)