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

minor improvements, mostly formatting

Browse Source 
svn: r3745
This commit is contained in:
Eli Barzilay 2006-07-17 20:26:55 +00:00
parent 96034746fc
commit c6fbade5d3
1 changed files with 193 additions and 215 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

408
collects/net/url-unit.ss
View File

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