minor improvements, mostly formatting
svn: r3745
This commit is contained in:
Eli Barzilay
parent
96034746fc
commit
c6fbade5d3
|
|
@ -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)))))
|
||||
(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-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
|
||||
(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)) ""))))))
|
||||
(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,133 +165,125 @@
|
|||
(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 empty-url?
|
||||
(lambda (url)
|
||||
(and (not (url-scheme url))
|
||||
(not (url-query url))
|
||||
(not (url-fragment url))
|
||||
(null? (url-path url)))))
|
||||
(define (display-pure-port server->client)
|
||||
(copy-port server->client (current-output-port))
|
||||
(close-input-port server->client))
|
||||
|
||||
(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-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
|
||||
(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)))
|
||||
(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
|
||||
(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))))
|
||||
(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
|
||||
|
|
@ -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))))))
|
||||
(join ";" (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)))]))])))))
|
||||
(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))))]))
|
||||
|
||||
)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user