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

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

@ -33,7 +33,8 @@
(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
(lambda (v)
(unless (and (list? v) (unless (and (list? v)
(andmap (andmap
(lambda (v) (lambda (v)
@ -58,41 +59,37 @@
(caddr v))) (caddr v)))
v))))) v)))))
(define url-error (define (url-error fmt . args)
(lambda (fmt . args) (let ([s (string->immutable-string
(let ((s (string->immutable-string (apply format fmt
(apply format fmt (map (lambda (arg) (map (lambda (arg)
(if (url? arg) (if (url? arg) (url->string arg) arg))
(url->string arg) args)))])
arg)) (raise (make-url-exception s (current-continuation-marks)))))
args)))))
(raise (make-url-exception s (current-continuation-marks))))))
(define url->string (define (url->string url)
(lambda (url) (let ([scheme (url-scheme url)]
(let ((scheme (url-scheme url)) [user (url-user url)]
(user (url-user url)) [host (url-host url)]
(host (url-host url)) [port (url-port url)]
(port (url-port url)) [path (url-path url)]
(path (url-path url)) [query (url-query url)]
(query (url-query url)) [fragment (url-fragment url)]
(fragment (url-fragment url))) [sa string-append])
(let ((sa string-append))
(sa (if scheme (sa scheme ":") "") (sa (if scheme (sa scheme ":") "")
(if (or user host port) (if (or user host port)
(sa (sa "//"
"//"
(if user (sa (uri-encode user) "@") "") (if user (sa (uri-encode user) "@") "")
(if host host "") (if host host "")
(if port (sa ":" (number->string port)) "") (if port (sa ":" (number->string port)) "")
; There used to be a "/" here, but that causes an ;; There used to be a "/" here, but that causes an
; extra leading slash -- wonder why it ever worked! ;; extra leading slash -- wonder why it ever worked!
) )
"") "")
(combine-path-strings (url-path-absolute? url) path) (combine-path-strings (url-path-absolute? url) path)
;(if query (sa "?" (uri-encode query)) "") ;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query))) (if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) "")))))) (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,18 +165,15 @@
(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
@ -191,26 +185,25 @@
(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 [else (url-error "Scheme ~a unsupported" scheme)])))
(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
@ -225,18 +218,15 @@
[(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)
@ -291,8 +281,7 @@
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)))]))
@ -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
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing) (dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client)) (lambda () (handler server->client))
(lambda () (close-input-port 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) #\/) (if (char=? (string-ref string 0) #\/) "file" "http"))
"file" url)))))
"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 (add-between bet lst) (define (join sep strings)
(cond (cond [(null? strings) ""]
[(null? lst) null] [(null? (cdr strings)) (car strings)]
[(null? (cdr lst)) lst]
[else [else
(let loop ([fst (car lst)] (let loop ([strings (cdr strings)] [r (list (car strings))])
[lst (cdr lst)]) (if (null? strings)
(cond (apply string-append (reverse! r))
[(null? lst) (list fst)] (loop (cdr strings) (list* (car strings) sep r))))]))
[else (list* fst
bet )))
(loop (car lst)
(cdr lst)))]))])))))