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 current-proxy-servers
(make-parameter null (lambda (v)
(make-parameter null
(lambda (v)
(unless (and (list? v)
(andmap
(lambda (v)
@ -58,41 +59,37 @@
(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))
(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
"//"
(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!
;; 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 query (sa "?" (uri-encode 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
(define (url->default-port url)
@ -168,18 +165,15 @@
(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
@ -191,26 +185,25 @@
(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 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)))
(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))))))
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
@ -225,18 +218,15 @@
[(url post-data strings) (getpost-pure-port #f url post-data strings)]))
;; display-pure-port : in-port -> ()
(define display-pure-port
(lambda (server->client)
(define (display-pure-port server->client)
(copy-port server->client (current-output-port))
(close-input-port server->client)))
(close-input-port server->client))
(define empty-url?
(lambda (url)
(define (empty-url? url)
(and (not (url-scheme url))
(not (url-query url))
(not (url-fragment url))
(null? (url-path url)))))
(null? (url-path url))))
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
@ -291,8 +281,7 @@
T))
(define (all-but-last lst)
(cond
[(null? lst) null]
(cond [(null? lst) null]
[(null? (cdr lst)) null]
[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)
;; [x list (str)] -> T
(define call/input-url
(let ((handle-port (lambda (server->client handler)
(let ([handle-port
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client))
(lambda () (close-input-port 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)])
(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)))
(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))))))
(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) ".."]
(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]
(define (join sep strings)
(cond [(null? strings) ""]
[(null? (cdr strings)) (car strings)]
[else
(let loop ([fst (car lst)]
[lst (cdr lst)])
(cond
[(null? lst) (list fst)]
[else (list* fst
bet
(loop (car lst)
(cdr lst)))]))])))))
(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))))]))
)))