From 3d6089d41c042d00224d727566d1577182e9cb0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 May 2001 21:24:33 +0000 Subject: [PATCH] . original commit: 9527ba8a9d865033d48bc08259583cc18bc7f455 --- collects/net/url-sig.ss | 1 - collects/net/url-unit.ss | 349 ++++++++++++++++++--------------------- 2 files changed, 164 insertions(+), 186 deletions(-) diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss index a131573..06e4d8b 100644 --- a/collects/net/url-sig.ss +++ b/collects/net/url-sig.ss @@ -4,7 +4,6 @@ (define-signature net:url^ ((struct url (scheme host port path params query fragment)) - (struct mime-header (name value)) get-pure-port ;; url [x list (str)] -> in-port get-impure-port ;; url [x list (str)] -> in-port display-pure-port ;; in-port -> () diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index e4c83db..82b0b62 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -21,8 +21,8 @@ (define-struct (url-exception struct:exn) ()) - ;; This is commented out; it's here for debugging. - ;; It used to be outside the unit. + ;; This is commented out; it's here for debugging. + ;; It used to be outside the unit. (quote (begin @@ -43,19 +43,15 @@ args)))) (raise (make-url-exception s (current-continuation-marks)))))) - ;; scheme : str + #f - ;; host : str + #f - ;; port : num + #f - ;; path : str - ;; params : str + #f - ;; query : str + #f - ;; fragment : str + #f + ;; scheme : str + #f + ;; host : str + #f + ;; port : num + #f + ;; path : str + ;; params : str + #f + ;; query : str + #f + ;; fragment : str + #f (define-struct url (scheme host port path params query fragment)) - ;; name : str (all lowercase; not including the colon) - ;; value : str (doesn't have the eol delimiter) - (define-struct mime-header (name value)) - (define url->string (lambda (url) (let ((scheme (url-scheme url)) @@ -66,38 +62,38 @@ (query (url-query url)) (fragment (url-fragment url))) (cond - ((and scheme (string=? scheme "file")) - (string-append "file:" path)) - (else - (let ((sa string-append)) - (sa (if scheme (sa scheme "://") "") - (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! - path - (if params (sa ";" params) "") - (if query (sa "?" query) "") - (if fragment (sa "#" fragment) "")))))))) + ((and scheme (string=? scheme "file")) + (string-append "file:" path)) + (else + (let ((sa string-append)) + (sa (if scheme (sa scheme "://") "") + (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! + path + (if params (sa ";" params) "") + (if query (sa "?" query) "") + (if fragment (sa "#" fragment) "")))))))) - ;; url->default-port : url -> num + ;; url->default-port : url -> num (define url->default-port (lambda (url) (let ((scheme (url-scheme url))) (cond - ((not scheme) 80) - ((string=? scheme "http") 80) - (else - (url-error "Scheme ~a not supported" (url-scheme url))))))) + ((not scheme) 80) + ((string=? scheme "http") 80) + (else + (url-error "Scheme ~a not supported" (url-scheme url))))))) - ;; make-ports : url -> in-port x out-port + ;; make-ports : url -> in-port x out-port (define make-ports (lambda (url) (let ((port-number (or (url-port url) (url->default-port url)))) (tcp-connect (url-host url) port-number)))) - ;; http://get-impure-port : url [x list (str)] -> in-port + ;; http://get-impure-port : url [x list (str)] -> in-port (define http://get-impure-port (case-lambda [(url) (http://get-impure-port url '())] @@ -119,48 +115,48 @@ (close-output-port client->server) server->client)])) - ;; file://get-pure-port : url -> in-port + ;; file://get-pure-port : url -> in-port (define file://get-pure-port (lambda (url) (when (url-host url) (url-error "Don't know how to get files from remote hosts")) (open-input-file (url-path url)))) - ;; get-impure-port : url [x list (str)] -> in-port + ;; get-impure-port : url [x list (str)] -> in-port (define get-impure-port (case-lambda [(url) (get-impure-port url '())] [(url strings) (let ((scheme (url-scheme url))) (cond - ((not scheme) - (url-error "Scheme unspecified in ~a" url)) - ((string=? scheme "http") - (http://get-impure-port url strings)) - ((string=? scheme "file") - (url-error "There are no impure file: ports")) - (else - (url-error "Scheme ~a unsupported" scheme))))])) + ((not scheme) + (url-error "Scheme unspecified in ~a" url)) + ((string=? scheme "http") + (http://get-impure-port url strings)) + ((string=? scheme "file") + (url-error "There are no impure file: ports")) + (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 (case-lambda [(url) (get-pure-port url '())] [(url strings) (let ((scheme (url-scheme url))) (cond - ((not scheme) - (url-error "Scheme unspecified in ~a" url)) - ((string=? scheme "http") - (let ((port (http://get-impure-port url strings))) - (purify-port port) - port)) - ((string=? scheme "file") - (file://get-pure-port url)) - (else - (url-error "Scheme ~a unsupported" scheme))))])) + ((not scheme) + (url-error "Scheme unspecified in ~a" url)) + ((string=? scheme "http") + (let ((port (http://get-impure-port url strings))) + (purify-port port) + port)) + ((string=? scheme "file") + (file://get-pure-port url)) + (else + (url-error "Scheme ~a unsupported" scheme))))])) - ;; display-pure-port : in-port -> () + ;; display-pure-port : in-port -> () (define display-pure-port (lambda (server->client) (let loop () @@ -177,17 +173,17 @@ (andmap (lambda (c) (char=? c #\space)) (string->list (url-path url)))))) - ;; file://combine-url/relative : fs-path x s/t/r -> fs-path + ;; file://combine-url/relative : fs-path x s/t/r -> fs-path (define file://combine-url/relative (let ((path-segment-regexp (regexp "([^/]*)/(.*)")) (translate-dir (lambda (s) (cond - [(string=? s "") 'same] ;; handle double slashes - [(string=? s "..") 'up] - [(string=? s ".") 'same] - [else s])))) + [(string=? s "") 'same] ;; handle double slashes + [(string=? s "..") 'up] + [(string=? s ".") 'same] + [else s])))) (lambda (index offset) (let*-values ([(simple-index) (simplify-path index)] [(base name dir?) @@ -204,60 +200,60 @@ (let loop ((str offset)) (let ((m (regexp-match path-segment-regexp str))) (cond - [(not m) str] - [else - (if (string=? "" (caddr m)) - (translate-dir (cadr m)) - (build-path (translate-dir (cadr m)) - (loop (caddr m))))]))))))))) + [(not m) str] + [else + (if (string=? "" (caddr m)) + (translate-dir (cadr m)) + (build-path (translate-dir (cadr m)) + (loop (caddr m))))]))))))))) - ;; combine-url/relative : url x str -> url + ;; combine-url/relative : url x str -> url (define combine-url/relative (lambda (base string) (let ((relative (string->url string))) (cond - ((empty-url? base) ; Step 1 - relative) - ((empty-url? relative) ; Step 2a - base) - ((url-scheme relative) ; Step 2b - relative) - (else ; Step 2c - (set-url-scheme! relative (url-scheme base)) - (cond - ;; This case is here because the above tests - ;; ensure the relative extension is not really - ;; an absolute path itself, so we need not - ;; examine its contents further. - ((and (url-scheme base) ; Interloper step - (string=? (url-scheme base) "file")) - (set-url-path! relative - (file://combine-url/relative - (url-path base) - (url-path relative))) - relative) - ((url-host relative) ; Step 3 - relative) - (else - (set-url-host! relative (url-host base)) - (set-url-port! relative (url-port base)) ; Unspecified! - (let ((rel-path (url-path relative))) - (cond - ((and rel-path ; Step 4 - (not (string=? "" rel-path)) - (char=? #\/ (string-ref rel-path 0))) - relative) - ((or (not rel-path) ; Step 5 - (string=? rel-path "")) - (set-url-path! relative (url-path base)) - (or (url-params relative) - (set-url-params! relative (url-params base))) - (or (url-query relative) - (set-url-query! relative (url-query base))) - relative) - (else ; Step 6 - (merge-and-normalize - (url-path base) relative))))))))))) + ((empty-url? base) ; Step 1 + relative) + ((empty-url? relative) ; Step 2a + base) + ((url-scheme relative) ; Step 2b + relative) + (else ; Step 2c + (set-url-scheme! relative (url-scheme base)) + (cond + ;; This case is here because the above tests + ;; ensure the relative extension is not really + ;; an absolute path itself, so we need not + ;; examine its contents further. + ((and (url-scheme base) ; Interloper step + (string=? (url-scheme base) "file")) + (set-url-path! relative + (file://combine-url/relative + (url-path base) + (url-path relative))) + relative) + ((url-host relative) ; Step 3 + relative) + (else + (set-url-host! relative (url-host base)) + (set-url-port! relative (url-port base)) ; Unspecified! + (let ((rel-path (url-path relative))) + (cond + ((and rel-path ; Step 4 + (not (string=? "" rel-path)) + (char=? #\/ (string-ref rel-path 0))) + relative) + ((or (not rel-path) ; Step 5 + (string=? rel-path "")) + (set-url-path! relative (url-path base)) + (or (url-params relative) + (set-url-params! relative (url-params base))) + (or (url-query relative) + (set-url-query! relative (url-query base))) + relative) + (else ; Step 6 + (merge-and-normalize + (url-path base) relative))))))))))) (define merge-and-normalize (lambda (base-path relative-url) @@ -323,57 +319,40 @@ (apply string-append grouped)) relative-url))))) - ;; call/input-url : url x (url -> in-port) x (in-port -> T) - ;; [x list (str)] -> T + ;; 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)))))) + (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))))) - (define empty-line? - (lambda (chars) - (or (null? chars) - (and (memv (car chars) '(#\return #\linefeed #\tab #\space)) - (empty-line? (cdr chars)))))) - - (define extract-mime-headers-as-char-lists - (lambda (port) - (let headers-loop ((headers '())) - (let char-loop ((header '())) - (let ((c (read-char port))) - (if (eof-object? c) - (reverse headers) ; CHECK: INCOMPLETE MIME: SERVER BUG - (if (char=? c #\newline) - (if (empty-line? header) - (reverse headers) - (begin - (headers-loop (cons (reverse header) headers)))) - (char-loop (cons c header))))))))) - - ;; purify-port : in-port -> list (mime-header) + ;; purify-port : in-port -> header-string (define purify-port (lambda (port) - (let ((headers-as-chars (extract-mime-headers-as-char-lists port))) - (let header-loop ((headers headers-as-chars)) - (if (null? headers) - '() - (let ((header (car headers))) - (let char-loop ((pre '()) (post header)) - (if (null? post) - (header-loop (cdr headers)) - (if (char=? #\: (car post)) - (cons (make-mime-header - (list->string (reverse pre)) - (list->string post)) - (header-loop (cdr headers))) - (char-loop (cons (char-downcase (car post)) pre) - (cdr post))))))))))) + (let char-loop ([chars '()][empty-line? #t]) + (let ([c (read-char port)]) + (if (eof-object? c) + (list->string (reverse chars)) ; INCOMPLETE MIME + (if (char=? c #\return) + ;; Got CR; look for LF: + (let ([c2 (read-char port)]) + (if (eq? c2 #\newline) + ;; that's a line + (let ([chars (list* c2 c chars)]) + (if empty-line? + (list->string (reverse chars)) + (char-loop chars #t))) + ;; ERROR: CR without LF + (if (eof-object? c2) + (list->string (reverse (cons c chars))) ; INCOMPLETE MIME + (char-loop (list* c2 c chars) #f)))) + (char-loop (cons c chars) #f))))))) (define character-set-size 256) @@ -390,7 +369,7 @@ (lambda (c) (vector-ref marker-locations (char->integer c)))) - ;; netscape/string->url : str -> url + ;; netscape/string->url : str -> url (define netscape/string->url (lambda (string) (let ((url (string->url string))) @@ -405,7 +384,7 @@ "http")) url)))))) - ;; string->url : str -> url + ;; string->url : str -> url (define string->url (lambda (string) (let loop ((markers ascii-marker-list)) @@ -479,7 +458,7 @@ (substring string fragment-start fragment-finish)))))))))))) - ;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str + ;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str (define parse-host/port/path (lambda (path begin-point end-point) (when (> begin-point end-point) @@ -495,36 +474,36 @@ (first-colon #f) (first-slash #f)) (cond - ((>= index end-point) - ;; We come here only if the string has not had a / - ;; yet. This can happen in two cases: - ;; 1. The input is a relative URL, and the hostname - ;; will not be specified. In such cases, has-host? - ;; will be false. - ;; 2. The input is an absolute URL with a hostname, - ;; and the intended path is "/", but the URL is missing - ;; a "/" at the end. has-host? must be true. - (let ((host/path (substring path begin-point end-point))) - (if has-host? - (values host/path #f "/") - (values #f #f host/path)))) - ((char=? #\: (string-ref path index)) - (loop (add1 index) (or first-colon index) first-slash)) - ((char=? #\/ (string-ref path index)) - (if first-colon - (values - (substring path begin-point first-colon) - (string->number (substring path (add1 first-colon) - index)) - (substring path index end-point)) - (if has-host? - (values - (substring path begin-point index) - #f - (substring path index end-point)) - (values - #f - #f - (substring path begin-point end-point))))) - (else - (loop (add1 index) first-colon first-slash))))))))))) + ((>= index end-point) + ;; We come here only if the string has not had a / + ;; yet. This can happen in two cases: + ;; 1. The input is a relative URL, and the hostname + ;; will not be specified. In such cases, has-host? + ;; will be false. + ;; 2. The input is an absolute URL with a hostname, + ;; and the intended path is "/", but the URL is missing + ;; a "/" at the end. has-host? must be true. + (let ((host/path (substring path begin-point end-point))) + (if has-host? + (values host/path #f "/") + (values #f #f host/path)))) + ((char=? #\: (string-ref path index)) + (loop (add1 index) (or first-colon index) first-slash)) + ((char=? #\/ (string-ref path index)) + (if first-colon + (values + (substring path begin-point first-colon) + (string->number (substring path (add1 first-colon) + index)) + (substring path index end-point)) + (if has-host? + (values + (substring path begin-point index) + #f + (substring path index end-point)) + (values + #f + #f + (substring path begin-point end-point))))) + (else + (loop (add1 index) first-colon first-slash)))))))))))