diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index 44e9621999..ca311159c7 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -33,66 +33,63 @@ (define-struct (url-exception exn:fail) ()) (define current-proxy-servers - (make-parameter null (lambda (v) - (unless (and (list? v) - (andmap - (lambda (v) - (and (list? v) - (= 3 (length v)) - (equal? (car v) "http") - (string? (car v)) - (number? (caddr v)) - (exact? (caddr v)) - (integer? (caddr v)) - (<= 1 (caddr v) 65535))) - v)) - (raise-type-error - 'current-proxy-servers - "list of list of scheme, string, and exact integer in [1,65535]" - v)) - (apply - list-immutable - (map (lambda (v) - (list-immutable (string->immutable-string (car v)) - (string->immutable-string (cadr v)) - (caddr v))) - v))))) - - (define url-error - (lambda (fmt . args) - (let ((s (string->immutable-string - (apply format fmt (map (lambda (arg) - (if (url? arg) - (url->string arg) - arg)) - args))))) - (raise (make-url-exception s (current-continuation-marks)))))) - - (define url->string - (lambda (url) - (let ((scheme (url-scheme url)) - (user (url-user url)) - (host (url-host url)) - (port (url-port url)) - (path (url-path url)) - (query (url-query url)) - (fragment (url-fragment url))) - (let ((sa string-append)) - (sa (if scheme (sa scheme ":") "") - (if (or user host port) - (sa - "//" - (if user (sa (uri-encode user) "@") "") - (if host host "") - (if port (sa ":" (number->string port)) "") - ; There used to be a "/" here, but that causes an - ; extra leading slash -- wonder why it ever worked! - ) - "") - (combine-path-strings (url-path-absolute? url) path) - ;(if query (sa "?" (uri-encode query)) "") - (if (null? query) "" (sa "?" (alist->form-urlencoded query))) - (if fragment (sa "#" (uri-encode fragment)) "")))))) + (make-parameter null + (lambda (v) + (unless (and (list? v) + (andmap + (lambda (v) + (and (list? v) + (= 3 (length v)) + (equal? (car v) "http") + (string? (car v)) + (number? (caddr v)) + (exact? (caddr v)) + (integer? (caddr v)) + (<= 1 (caddr v) 65535))) + v)) + (raise-type-error + 'current-proxy-servers + "list of list of scheme, string, and exact integer in [1,65535]" + v)) + (apply + list-immutable + (map (lambda (v) + (list-immutable (string->immutable-string (car v)) + (string->immutable-string (cadr v)) + (caddr v))) + v))))) + + (define (url-error fmt . args) + (let ([s (string->immutable-string + (apply format fmt + (map (lambda (arg) + (if (url? arg) (url->string arg) arg)) + args)))]) + (raise (make-url-exception s (current-continuation-marks))))) + + (define (url->string url) + (let ([scheme (url-scheme url)] + [user (url-user url)] + [host (url-host url)] + [port (url-port url)] + [path (url-path url)] + [query (url-query url)] + [fragment (url-fragment url)] + [sa string-append]) + (sa (if scheme (sa scheme ":") "") + (if (or user host port) + (sa "//" + (if user (sa (uri-encode user) "@") "") + (if host host "") + (if port (sa ":" (number->string port)) "") + ;; There used to be a "/" here, but that causes an + ;; extra leading slash -- wonder why it ever worked! + ) + "") + (combine-path-strings (url-path-absolute? url) path) + ;; (if query (sa "?" (uri-encode query)) "") + (if (null? query) "" (sa "?" (alist->form-urlencoded query))) + (if fragment (sa "#" (uri-encode fragment)) "")))) ;; url->default-port : url -> num (define (url->default-port url) @@ -168,134 +165,126 @@ (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) ;; getpost-impure-port : bool x url x list (str) -> in-port - (define getpost-impure-port - (lambda (get? url post-data strings) - (let ((scheme (url-scheme url))) - (cond - ((not scheme) - (schemeless-url url)) - ((string=? scheme "http") - (http://getpost-impure-port get? url post-data strings)) - ((string=? scheme "file") - (url-error "There are no impure file: ports")) - (else - (url-error "Scheme ~a unsupported" scheme)))))) + (define (getpost-impure-port get? url post-data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(string=? scheme "http") + (http://getpost-impure-port get? url post-data strings)] + [(string=? scheme "file") + (url-error "There are no impure file: ports")] + [else (url-error "Scheme ~a unsupported" scheme)]))) ;; get-impure-port : url [x list (str)] -> in-port (define get-impure-port (case-lambda - [(url) (get-impure-port url '())] - [(url strings) (getpost-impure-port #t url #f strings)])) + [(url) (get-impure-port url '())] + [(url strings) (getpost-impure-port #t url #f strings)])) ;; post-impure-port : url x bytes [x list (str)] -> in-port (define post-impure-port (case-lambda - [(url post-data) (post-impure-port url post-data '())] - [(url post-data strings) (getpost-impure-port #f url post-data strings)])) + [(url post-data) (post-impure-port url post-data '())] + [(url post-data strings) + (getpost-impure-port #f url post-data strings)])) ;; getpost-pure-port : bool x url x list (str) -> in-port - (define getpost-pure-port - (lambda (get? url post-data strings) - (let ((scheme (url-scheme url))) - (cond - ((not scheme) - (schemeless-url url)) - ((string=? scheme "http") - (let ((port (http://getpost-impure-port get? url post-data strings))) - (with-handlers ([void (lambda (exn) - (close-input-port port) - (raise exn))]) - (purify-port port)) - port)) - ((string=? scheme "file") - (file://get-pure-port url)) - (else - (url-error "Scheme ~a unsupported" scheme)))))) + (define (getpost-pure-port get? url post-data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(string=? scheme "http") + (let ([port (http://getpost-impure-port + get? url post-data strings)]) + (with-handlers ([void (lambda (exn) + (close-input-port port) + (raise exn))]) + (purify-port port)) + port)] + [(string=? scheme "file") + (file://get-pure-port url)] + [else (url-error "Scheme ~a unsupported" scheme)]))) ;; get-pure-port : url [x list (str)] -> in-port (define get-pure-port (case-lambda - [(url) (get-pure-port url '())] - [(url strings) (getpost-pure-port #t url #f strings)])) + [(url) (get-pure-port url '())] + [(url strings) (getpost-pure-port #t url #f strings)])) ;; post-pure-port : url bytes [x list (str)] -> in-port (define post-pure-port (case-lambda - [(url post-data) (post-pure-port url post-data '())] - [(url post-data strings) (getpost-pure-port #f url post-data strings)])) + [(url post-data) (post-pure-port url post-data '())] + [(url post-data strings) (getpost-pure-port #f url post-data strings)])) ;; display-pure-port : in-port -> () - (define display-pure-port - (lambda (server->client) - (copy-port server->client (current-output-port)) - (close-input-port server->client))) + (define (display-pure-port server->client) + (copy-port server->client (current-output-port)) + (close-input-port server->client)) - (define empty-url? - (lambda (url) - (and (not (url-scheme url)) - (not (url-query url)) - (not (url-fragment url)) - (null? (url-path url))))) + (define (empty-url? url) + (and (not (url-scheme url)) + (not (url-query url)) + (not (url-fragment url)) + (null? (url-path url)))) - ;; transliteration of code in rfc 3986, section 5.2.2 (define (combine-url/relative Base string) (let ([R (string->url string)] [T (make-url #f #f #f #f #f '() '() #f)]) (if (url-scheme R) - (begin - (set-url-scheme! T (url-scheme R)) - (set-url-user! T (url-user R)) ;; authority - (set-url-host! T (url-host R)) ;; authority - (set-url-port! T (url-port R)) ;; authority - (set-url-path-absolute?! T (url-path-absolute? R)) - (set-url-path! T (remove-dot-segments (url-path R))) - (set-url-query! T (url-query R))) - (begin - (if (url-host R) ;; => authority is defined - (begin - (set-url-user! T (url-user R)) ;; authority - (set-url-host! T (url-host R)) ;; authority - (set-url-port! T (url-port R)) ;; authority - (set-url-path-absolute?! T (url-path-absolute? R)) - (set-url-path! T (remove-dot-segments (url-path R))) - (set-url-query! T (url-query R))) + (begin + (set-url-scheme! T (url-scheme R)) + (set-url-user! T (url-user R)) ;; authority + (set-url-host! T (url-host R)) ;; authority + (set-url-port! T (url-port R)) ;; authority + (set-url-path-absolute?! T (url-path-absolute? R)) + (set-url-path! T (remove-dot-segments (url-path R))) + (set-url-query! T (url-query R))) + (begin + (if (url-host R) ;; => authority is defined + (begin + (set-url-user! T (url-user R)) ;; authority + (set-url-host! T (url-host R)) ;; authority + (set-url-port! T (url-port R)) ;; authority + (set-url-path-absolute?! T (url-path-absolute? R)) + (set-url-path! T (remove-dot-segments (url-path R))) + (set-url-query! T (url-query R))) + (begin + (if (null? (url-path R)) ;; => R has empty path (begin - (if (null? (url-path R)) ;; => R has empty path - (begin - (set-url-path-absolute?! T (url-path-absolute? Base)) - (set-url-path! T (url-path Base)) - (if (not (null? (url-query R))) - (set-url-query! T (url-query R)) - (set-url-query! T (url-query Base)))) - (begin - (cond - [(url-path-absolute? R) - (set-url-path-absolute?! T #t) - (set-url-path! T (remove-dot-segments (url-path R)))] - [(and (null? (url-path Base)) - (url-host Base)) - (set-url-path-absolute?! T #t) - (set-url-path! T (remove-dot-segments (url-path R)))] - [else - (set-url-path-absolute?! T (url-path-absolute? Base)) - (set-url-path! T (remove-dot-segments - (append (all-but-last (url-path Base)) - (url-path R))))]) - (set-url-query! T (url-query R)))) - (set-url-user! T (url-user Base)) ;; authority - (set-url-host! T (url-host Base)) ;; authority - (set-url-port! T (url-port Base)))) ;; authority - (set-url-scheme! T (url-scheme Base)))) + (set-url-path-absolute?! T (url-path-absolute? Base)) + (set-url-path! T (url-path Base)) + (if (not (null? (url-query R))) + (set-url-query! T (url-query R)) + (set-url-query! T (url-query Base)))) + (begin + (cond + [(url-path-absolute? R) + (set-url-path-absolute?! T #t) + (set-url-path! T (remove-dot-segments (url-path R)))] + [(and (null? (url-path Base)) + (url-host Base)) + (set-url-path-absolute?! T #t) + (set-url-path! T (remove-dot-segments (url-path R)))] + [else + (set-url-path-absolute?! T (url-path-absolute? Base)) + (set-url-path! T (remove-dot-segments + (append (all-but-last (url-path Base)) + (url-path R))))]) + (set-url-query! T (url-query R)))) + (set-url-user! T (url-user Base)) ;; authority + (set-url-host! T (url-host Base)) ;; authority + (set-url-port! T (url-port Base)))) ;; authority + (set-url-scheme! T (url-scheme Base)))) (set-url-fragment! T (url-fragment R)) T)) - + (define (all-but-last lst) - (cond - [(null? lst) null] - [(null? (cdr lst)) null] - [else (cons (car lst) (all-but-last (cdr lst)))])) - + (cond [(null? lst) null] + [(null? (cdr lst)) null] + [else (cons (car lst) (all-but-last (cdr lst)))])) + ;; cribbed from 5.2.4 in rfc 3986 ;; the strange cases 2 and 4 implicitly change urls ;; with paths segments "." and ".." at the end @@ -330,40 +319,38 @@ ;; call/input-url : url x (url -> in-port) x (in-port -> T) ;; [x list (str)] -> T (define call/input-url - (let ((handle-port (lambda (server->client handler) - (dynamic-wind (lambda () 'do-nothing) - (lambda () (handler server->client)) - (lambda () (close-input-port server->client)))))) + (let ([handle-port + (lambda (server->client handler) + (dynamic-wind (lambda () 'do-nothing) + (lambda () (handler server->client)) + (lambda () (close-input-port server->client))))]) (case-lambda - ((url getter handler) - (handle-port (getter url) handler)) - ((url getter handler params) - (handle-port (getter url params) handler))))) + [(url getter handler) + (handle-port (getter url) handler)] + [(url getter handler params) + (handle-port (getter url params) handler)]))) ;; purify-port : in-port -> header-string - (define purify-port - (lambda (port) - (let ([m (regexp-match-peek-positions #rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))" port)]) - (if m - (read-string (cdar m) port) - "")))) + (define (purify-port port) + (let ([m (regexp-match-peek-positions + #rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))" port)]) + (if m + (read-string (cdar m) port) + ""))) (define character-set-size 256) ;; netscape/string->url : str -> url - (define netscape/string->url - (lambda (string) - (let ((url (string->url string))) - (if (url-scheme url) - url - (if (string=? string "") - (url-error "Can't resolve empty string as URL") - (begin - (set-url-scheme! url - (if (char=? (string-ref string 0) #\/) - "file" - "http")) - url)))))) + (define (netscape/string->url string) + (let ([url (string->url string)]) + (if (url-scheme url) + url + (if (string=? string "") + (url-error "Can't resolve empty string as URL") + (begin + (set-url-scheme! url + (if (char=? (string-ref string 0) #\/) "file" "http")) + url))))) ;; string->url : str -> url ;; New implementation, mostly provided by Neil Van Dyke @@ -433,37 +420,28 @@ [else (uri-path-segment-decode p)])) (define (path-segment-encode p) - (cond - [(eq? p 'up) ".."] - [(eq? p 'same) "."] - [(equal? p "..") "%2e%2e"] - [(equal? p ".") "%2e"] - [else (uri-path-segment-encode p)])) - + (cond [(eq? p 'up) ".."] + [(eq? p 'same) "."] + [(equal? p "..") "%2e%2e"] + [(equal? p ".") "%2e"] + [else (uri-path-segment-encode p)])) + (define (combine-path-strings absolute? path/params) - (cond - [(null? path/params) ""] - [else - (apply string-append - (if absolute? "/" "") - (add-between "/" (map join-params path/params)))])) + (cond [(null? path/params) ""] + [else (let ([p (join "/" (map join-params path/params))]) + (if absolute? (string-append "/" p) p))])) (define (join-params s) - (apply string-append - (add-between ";" (map path-segment-encode - (cons (path/param-path s) - (path/param-param s)))))) - - (define (add-between bet lst) - (cond - [(null? lst) null] - [(null? (cdr lst)) lst] - [else - (let loop ([fst (car lst)] - [lst (cdr lst)]) - (cond - [(null? lst) (list fst)] - [else (list* fst - bet - (loop (car lst) - (cdr lst)))]))]))))) + (join ";" (map path-segment-encode + (cons (path/param-path s) (path/param-param s))))) + + (define (join sep strings) + (cond [(null? strings) ""] + [(null? (cdr strings)) (car strings)] + [else + (let loop ([strings (cdr strings)] [r (list (car strings))]) + (if (null? strings) + (apply string-append (reverse! r)) + (loop (cdr strings) (list* (car strings) sep r))))])) + + )))