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

.

Browse Source 
original commit: 282f99491878fb8b3fc512a0e3217c1ec67027ae
This commit is contained in:
Robby Findler 2004-03-21 02:37:42 +00:00
parent 920ab6d776
commit a3892e3a10
2 changed files with 90 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/net/url-sig.ss
View File

@ -3,23 +3,19 @@
(provide net:url^) (provide net:url^)
(define-signature net:url^ (define-signature net:url^
((struct url (scheme host port path params query fragment)) ((struct url (scheme user host port path query fragment))
(struct url/user (user)) ; sub-struct of url (struct path/param (path param))
get-pure-port ;; url [x list (str)] -> in-port get-pure-port
get-impure-port ;; url [x list (str)] -> in-port get-impure-port
post-pure-port ;; url [x list (str)] -> in-port post-pure-port
post-impure-port ;; url [x list (str)] -> in-port post-impure-port
display-pure-port ;; in-port -> () display-pure-port
purify-port ;; in-port -> list (mime-header) purify-port
netscape/string->url ;; (string -> url) netscape/string->url
string->url ;; str -> url string->url
url->string url->string
decode-some-url-parts ;; url -> url call/input-url
call/input-url ;; url x (url -> in-port) x combine-url/relative
;; (in-port -> T) url-exception?
;; [x list (str)] -> T current-proxy-servers)))
combine-url/relative ;; url x str -> url
url-exception? ;; T -> boolean
current-proxy-servers))) ;; (U ((U #f (list string num)) -> void) (-> (U #f (list string num))))

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

@ -73,15 +73,16 @@
args)))) args))))
(raise (make-url-exception s (current-continuation-marks)))))) (raise (make-url-exception s (current-continuation-marks))))))
(define-struct url (scheme host port path params query fragment user)) (define-struct url (scheme user host port path query fragment))
(define-struct path/param (path param))
(define url->string (define url->string
(lambda (url) (lambda (url)
(let ((scheme (url-scheme url)) (let ((scheme (url-scheme 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))
(params (url-params url))
(query (url-query url)) (query (url-query url))
(fragment (url-fragment url))) (fragment (url-fragment url)))
(cond (cond
@ -92,14 +93,14 @@
(else (else
(let ((sa string-append)) (let ((sa string-append))
(sa (if scheme (sa scheme "://") "") (sa (if scheme (sa scheme "://") "")
(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 path) (combine-path-strings path)
(if params (sa ";" params) "") (if query (sa "?" (uri-encode query)) "")
(if query (sa "?" query) "") (if fragment (sa "#" (uri-encode fragment)) ""))))))))
(if fragment (sa "#" fragment) ""))))))))
;; url->default-port : url -> num ;; url->default-port : url -> num
(define url->default-port (define url->default-port
@ -133,12 +134,10 @@
(url->string (url->string
(if proxy (if proxy
url url
(make-url #f #f #f (make-url #f #f #f #f
(url-path url) (url-path url)
(url-params url) (url-query url)
(url-query url) (url-fragment url))))))
(url-fragment url)
#f)))))
(for-each (lambda (s) (for-each (lambda (s)
(display s client->server) (display s client->server)
(display "\r\n" client->server)) (display "\r\n" client->server))
@ -231,8 +230,9 @@
(define empty-url? (define empty-url?
(lambda (url) (lambda (url)
(and (not (url-scheme url)) (not (url-params url)) (and (not (url-scheme url))
(not (url-query url)) (not (url-fragment url)) (not (url-query url))
(not (url-fragment url))
(andmap (lambda (c) (char=? c #\space)) (andmap (lambda (c) (char=? c #\space))
(string->list (url-path url)))))) (string->list (url-path url))))))
@ -309,8 +309,6 @@
((or (not rel-path) ; Step 5 ((or (not rel-path) ; Step 5
(string=? rel-path "")) (string=? rel-path ""))
(set-url-path! relative (url-path base)) (set-url-path! relative (url-path base))
(or (url-params relative)
(set-url-params! relative (url-params base)))
(or (url-query relative) (or (url-query relative)
(set-url-query! relative (url-query base))) (set-url-query! relative (url-query base)))
relative) relative)
@ -435,10 +433,10 @@
"(:[0-9]*)?" ; =6 colon-port-opt "(:[0-9]*)?" ; =6 colon-port-opt
")?" ; >3 slashslash-opt ")?" ; >3 slashslash-opt
")?" ; >1 front-opt ")?" ; >1 front-opt
"([^;?#]*)" ; =7 path "([^?#]*)" ; =7 path
"(;[^?#]*)?" ; =8 semi-parms-opt ;"(;[^?#]*)?" ; =8 semi-parms-opt
"(\\?[^#]*)?" ; =9 question-query-opt "(\\?[^#]*)?" ; =8 question-query-opt
"(#.*)?" ; =10 hash-fragment-opt "(#.*)?" ; =9 hash-fragment-opt
"[ \t\f\r\n]*" "[ \t\f\r\n]*"
"$")))) "$"))))
(lambda (str) (lambda (str)
@ -451,13 +449,12 @@
(if (or (relative-path? path) (if (or (relative-path? path)
(absolute-path? path)) (absolute-path? path))
(make-url "file" (make-url "file"
#f ; host #f ; user
#f ; host
#f ; port #f ; port
(separate-path-strings path) (separate-path-strings path)
#f ; params
#f ; query #f ; query
fragment fragment)
#f) ; user
(url-error "scheme 'file' path ~s neither relative nor absolute" path)))) (url-error "scheme 'file' path ~s neither relative nor absolute" path))))
;; Other scheme: ;; Other scheme:
(let ((match (regexp-match-positions rx str))) (let ((match (regexp-match-positions rx str)))
@ -474,22 +471,21 @@
(if s (string->number s) #f)))) (if s (string->number s) #f))))
(host (get-str 5 0 0))) (host (get-str 5 0 0)))
(make-url (get-str 2 0 1) ; scheme (make-url (get-str 2 0 1) ; scheme
host (uri-decode/maybe (get-str 4 0 1)) ; user
(get-num 6 1 0) ; port host
(separate-path-strings (get-num 6 1 0) ; port
(let ([path (get-str 7 0 0)]) (separate-path-strings
;; If path is "" and the input is an absolute URL (let ([path (get-str 7 0 0)])
;; with a hostname, then the intended path is "/", ;; If path is "" and the input is an absolute URL
;; but the URL is missing a "/" at the end. ;; with a hostname, then the intended path is "/",
(if (and (string=? path "") ;; but the URL is missing a "/" at the end.
host) (if (and (string=? path "")
"/" host)
path))) "/"
(get-str 8 1 0) ; params path)))
(uri-decode/maybe (get-str 9 1 0)) ; query (uri-decode/maybe (get-str 8 1 0)) ; query
(uri-decode/maybe (get-str 10 1 0)) ; fragment (uri-decode/maybe (get-str 9 1 0)) ; fragment
(get-str 4 0 1) ; user ))
))
(url-error "Invalid URL string: ~e" str)))))))) (url-error "Invalid URL string: ~e" str))))))))
(define (uri-decode/maybe f) (define (uri-decode/maybe f)
@ -498,45 +494,45 @@
;; in an attempt to be "friendly" ;; in an attempt to be "friendly"
(and f (uri-decode (regexp-replace* "%([^0-9a-fA-F])" f "%25\\1")))) (and f (uri-decode (regexp-replace* "%([^0-9a-fA-F])" f "%25\\1"))))
(define (decode-some-url-parts url) ;; separate-path-strings : string[starting with /] -> (listof (union string path/param))
(make-url/user (uri-decode/maybe (url-scheme url)) (define (separate-path-strings str)
(uri-decode/maybe (url-host url)) (when (or (string=? str "")
(uri-decode/maybe (url-port url)) (not (char=? (string-ref str 0) #\/)))
(uri-decode/maybe (url-path url)) (error 'separate-path-strings "got non path string, ~e" str))
(url-params url) (if (string=? str "/")
(url-query url) '()
(uri-decode/maybe (url-fragment url)) (let loop ([str (substring str 1 (string-length str))])
(if (url/user? url) (cond
(uri-decode/maybe (url/user-user url)) [(regexp-match #rx"([^/]*)/(.*)$" str)
#f))))) =>
(lambda (m)
;; separate-path-strings : string[starting with /] -> (listof string) (cons (maybe-separate-params (cadr m)) (loop (caddr m))))]
(define (separate-path-strings str) [else (list (maybe-separate-params str))]))))
(when (or (string=? str "")
(not (char=? (string-ref str 0) #\/))) (define (maybe-separate-params s)
(error 'separate-path-strings "got non path string, ~e" str)) (cond
(let loop ([str (substring str 1 (string-length str))]) [(regexp-match #rx"^([^;]*);(.*)$" s)
(cond =>
[(regexp-match #rx"([^/]*)/(.*)$" str) (lambda (m)
=> (make-path/param (cadr m) (caddr m)))]
(lambda (m) [else s]))
(cons (cadr m) (loop (caddr m))))]
[else (list str)]))) (define (combine-path-strings strs)
(apply
(define (combine-path-strings strs) string-append
(apply "/"
string-append (let loop ([strs strs])
(let loop ([strs strs]) (cond
(cond [(null? strs) '()]
[(null? strs) '()] [(null? (cdr strs)) (list (maybe-join-params (car strs)))]
[else (list* "/" [else (list* (maybe-join-params (car strs))
(car strs) "/"
(loop (cdr strs)))])))) (loop (cdr strs)))]))))
;; tests for path string combination and separation ;; needs to unquote things!
#; (define (maybe-join-params s)
(and (equal? (separate-path-strings "/a") (list "a")) (cond
(equal? (separate-path-strings "/a/b") (list "a" "b")) [(string? s) s]
(equal? (separate-path-strings "/a/b/c") (list "a" "b" "c")) [else (string-append (path/param-path s)
(equal? (combine-path-strings (list "a")) "/a") ";"
(equal? (combine-path-strings (list "a" "b")) "/a/b") (path/param-param s))])))))