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

reformatting

Browse Source 
svn: r9853
This commit is contained in:
Eli Barzilay 2008-05-15 16:55:15 +00:00
parent e62d2bf9ea
commit 0d41afdb6d
32 changed files with 3495 additions and 3579 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/net/base64-sig.ss
View File

@ -1,4 +1,3 @@
#lang scheme/signature #lang scheme/signature
base64-filename-safe base64-filename-safe

8
collects/net/base64.ss
View File

@ -1,8 +1,6 @@
(module base64 mzscheme #lang scheme/base
(require mzlib/unit (require scheme/unit "base64-sig.ss" "base64-unit.ss")
"base64-sig.ss"
"base64-unit.ss")
(define-values/invoke-unit/infer base64@) (define-values/invoke-unit/infer base64@)
(provide-signature-elements base64^)) (provide-signature-elements base64^)

16
collects/net/cgi-unit.ss
View File

@ -1,8 +1,5 @@
#lang scheme/unit #lang scheme/unit
(require "cgi-sig.ss" "uri-codec.ss")
(require mzlib/etc
"cgi-sig.ss"
"uri-codec.ss")
(import) (import)
(export cgi^) (export cgi^)
@ -60,17 +57,14 @@
;; generate-html-output : ;; generate-html-output :
;; html-string x list (html-string) x ... -> () ;; html-string x list (html-string) x ... -> ()
(define generate-html-output (define (generate-html-output title body-lines
(opt-lambda (title body-lines
[text-color default-text-color] [text-color default-text-color]
[bg-color default-bg-color] [bg-color default-bg-color]
[link-color default-link-color] [link-color default-link-color]
[vlink-color default-vlink-color] [vlink-color default-vlink-color]
[alink-color default-alink-color]) [alink-color default-alink-color])
(let ([sa string-append]) (let ([sa string-append])
(for-each (for ([l `("Content-type: text/html"
(lambda (l) (display l) (newline))
`("Content-type: text/html"
"" ""
"<html>" "<html>"
"<!-- The form was processed, and this document was generated," "<!-- The form was processed, and this document was generated,"
@ -90,7 +84,9 @@
,@body-lines ,@body-lines
"" ""
"</body>" "</body>"
"</html>"))))) "</html>")])
(display l)
(newline))))
;; output-http-headers : -> void ;; output-http-headers : -> void
(define (output-http-headers) (define (output-http-headers)

6
collects/net/cgi.ss
View File

@ -1,6 +1,6 @@
(module cgi mzscheme #lang scheme/base
(require mzlib/unit "cgi-sig.ss" "cgi-unit.ss") (require scheme/unit "cgi-sig.ss" "cgi-unit.ss")
(define-values/invoke-unit/infer cgi@) (define-values/invoke-unit/infer cgi@)
(provide-signature-elements cgi^)) (provide-signature-elements cgi^)

37
collects/net/cookie-unit.ss
View File

@ -50,16 +50,13 @@
#lang scheme/unit #lang scheme/unit
(require mzlib/etc (require srfi/13/string srfi/14/char-set "cookie-sig.ss")
mzlib/list
srfi/13/string
srfi/14/char-set
"cookie-sig.ss")
(import) (import)
(export cookie^) (export cookie^)
(define-struct cookie (name value comment domain max-age path secure version) #:mutable) (define-struct cookie
(name value comment domain max-age path secure version) #:mutable)
(define-struct (cookie-error exn:fail) ()) (define-struct (cookie-error exn:fail) ())
;; error* : string args ... -> raises a cookie-error exception ;; error* : string args ... -> raises a cookie-error exception
@ -103,17 +100,17 @@
;; Formats the cookie contents in a string ready to be appended to a ;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser). ;; "Set-Cookie: " header, and sent to a client (browser).
(define (print-cookie cookie) (define (print-cookie cookie)
(unless (cookie? cookie) (define (format-if fmt val) (and val (format fmt val)))
(error* "cookie expected, received: ~a" cookie)) (unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
(string-join (string-join
(filter (lambda (s) (not (string-null? s))) (filter values
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie)) (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) "")) (format-if "Comment=~a" (cookie-comment cookie))
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) "")) (format-if "Domain=~a" (cookie-domain cookie))
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) "")) (format-if "Max-Age=~a" (cookie-max-age cookie))
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) "")) (format-if "Path=~a" (cookie-path cookie))
(let ([s (cookie-secure cookie)]) (if s "Secure" "")) (and (cookie-secure cookie) "Secure")
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1))))) (format "Version=~a" (or (cookie-version cookie) 1))))
"; ")) "; "))
(define (cookie:add-comment cookie pre-comment) (define (cookie:add-comment cookie pre-comment)
@ -257,11 +254,10 @@
;; a character set for this definition because of two dependencies: CRLF must ;; a character set for this definition because of two dependencies: CRLF must
;; appear as a block to be legal, and " may only appear as \" ;; appear as a block to be legal, and " may only appear as \"
(define (rfc2068:quoted-string? s) (define (rfc2068:quoted-string? s)
(if (regexp-match (and (regexp-match?
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
s) s)
s s))
#f))
;; value: token | quoted-string ;; value: token | quoted-string
(define (rfc2109:value? s) (define (rfc2109:value? s)
@ -298,14 +294,13 @@
;; ;;
;; Returns whether this is a valid string to use as the value or the ;; Returns whether this is a valid string to use as the value or the
;; name (depending on value?) of an HTTP cookie. ;; name (depending on value?) of an HTTP cookie.
(define cookie-string? (define (cookie-string? s [value? #t])
(opt-lambda (s (value? #t))
(unless (string? s) (unless (string? s)
(error* "string expected, received: ~a" s)) (error* "string expected, received: ~a" s))
(if value? (if value?
(rfc2109:value? s) (rfc2109:value? s)
;; name: token ;; name: token
(rfc2068:token? s)))) (rfc2068:token? s)))
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-) ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname (define char-set:hostname

6
collects/net/cookie.ss
View File

@ -1,6 +1,6 @@
(module cookie mzscheme #lang scheme/base
(require mzlib/unit "cookie-sig.ss" "cookie-unit.ss") (require scheme/unit "cookie-sig.ss" "cookie-unit.ss")
(provide-signature-elements cookie^) (provide-signature-elements cookie^)
(define-values/invoke-unit/infer cookie@)) (define-values/invoke-unit/infer cookie@)

31
collects/net/dns-unit.ss
View File

@ -1,7 +1,6 @@
#lang scheme/unit #lang scheme/unit
(require mzlib/list mzlib/process "dns-sig.ss" (require "dns-sig.ss" scheme/system scheme/udp)
scheme/udp)
(import) (import)
(export dns^) (export dns^)
@ -52,8 +51,7 @@
d)) d))
(define (name->octets s) (define (name->octets s)
(let ([do-one (lambda (s) (let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
(cons (bytes-length s) (bytes->list s)))])
(let loop ([s s]) (let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m (if m
@ -95,13 +93,12 @@
[(zero? (bitwise-and #xc0 v)) [(zero? (bitwise-and #xc0 v))
;; Normal label ;; Normal label
(let loop ([len v][start (cdr start)][accum null]) (let loop ([len v][start (cdr start)][accum null])
(cond (if (zero? len)
[(zero? len)
(let-values ([(s start) (parse-name start reply)]) (let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse accum))]) (let ([s0 (list->bytes (reverse accum))])
(values (if s (bytes-append s0 #"." s) s0) (values (if s (bytes-append s0 #"." s) s0)
start)))] start)))
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))] (loop (sub1 len) (cdr start) (cons (car start) accum))))]
[else [else
;; Compression offset ;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
@ -167,12 +164,10 @@
(let ([s (make-bytes 512)]) (let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT]) (let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query)) (udp-send-to udp nameserver 53 (list->bytes query))
(sync (handle-evt (sync (handle-evt (udp-receive!-evt udp s)
(udp-receive!-evt udp s)
(lambda (r) (lambda (r)
(bytes->list (subbytes s 0 (car r))))) (bytes->list (subbytes s 0 (car r)))))
(handle-evt (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
(alarm-evt (+ (current-inexact-milliseconds)
timeout)) timeout))
(lambda (v) (lambda (v)
(retry (* timeout 2)))))))) (retry (* timeout 2))))))))
@ -217,7 +212,8 @@
(let ([v (hash-ref cache key (lambda () #f))]) (let ([v (hash-ref cache key (lambda () #f))])
(if v (if v
(apply values v) (apply values v)
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)]) (let-values ([(auth? qds ans nss ars reply)
(dns-query nameserver addr type class)])
(hash-set! cache key (list auth? qds ans nss ars reply)) (hash-set! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply)))))) (values auth? qds ans nss ars reply))))))
@ -249,8 +245,7 @@
(list-ref result 1)))) (list-ref result 1))))
(define (get-ptr-list-from-ans ans) (define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
ans))
(define (dns-get-name nameserver ip) (define (dns-get-name nameserver ip)
(or (try-forwarding (or (try-forwarding
@ -334,12 +329,10 @@
(proc 'wait) (proc 'wait)
(or ip name)] (or ip name)]
[(and (not name) [(and (not name)
(regexp-match #rx"^Default Server: +(.*)$" (regexp-match #rx"^Default Server: +(.*)$" line))
line))
=> (lambda (m) (loop (cadr m) #f #t))] => (lambda (m) (loop (cadr m) #f #t))]
[(and try-ip? [(and try-ip?
(regexp-match #rx"^Address: +(.*)$" (regexp-match #rx"^Address: +(.*)$" line))
line))
=> (lambda (m) (loop name (cadr m) #f))] => (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))] [else (loop name ip #f)]))))))]
[else #f])) [else #f]))

6
collects/net/dns.ss
View File

@ -1,6 +1,6 @@
(module dns mzscheme #lang scheme/base
(require mzlib/unit "dns-sig.ss" "dns-unit.ss") (require scheme/unit "dns-sig.ss" "dns-unit.ss")
(define-values/invoke-unit/infer dns@) (define-values/invoke-unit/infer dns@)
(provide-signature-elements dns^)) (provide-signature-elements dns^)

6
collects/net/ftp.ss
View File

@ -1,6 +1,6 @@
(module ftp mzscheme #lang scheme/base
(require mzlib/unit "ftp-sig.ss" "ftp-unit.ss") (require scheme/unit "ftp-sig.ss" "ftp-unit.ss")
(define-values/invoke-unit/infer ftp@) (define-values/invoke-unit/infer ftp@)
(provide-signature-elements ftp^)) (provide-signature-elements ftp^)

8
collects/net/head-unit.ss
View File

@ -95,7 +95,6 @@
;; Rest of header is this field, but strip trailing CRLFCRLF: ;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$" s "")))))))) (regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header) (define (replace-field field data header)
(if (bytes? header) (if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field) (let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
@ -108,8 +107,7 @@
(bytes-append pre (if data (insert-field field data rest) rest))) (bytes-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header))) (if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings: ;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field) (let ([m (regexp-match-positions (make-field-start-regexp field) header)])
header)])
(if m (if m
(let* ([pre (substring header 0 (caaddr m))] (let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))] [s (substring header (cdaddr m))]
@ -242,9 +240,7 @@
(let* ([mq1 (regexp-match-positions re:quoted s)] (let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)] [mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2) [mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2)) (if (< (caar mq1) (caar mq2)) mq1 mq2)
mq1
mq2)
(or mq1 mq2))] (or mq1 mq2))]
[mc (regexp-match-positions re:comma s)]) [mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq))) (if (and mq mc (< (caar mq) (caar mc) (cdar mq)))

6
collects/net/head.ss
View File

@ -1,6 +1,6 @@
(module head mzscheme #lang scheme/base
(require mzlib/unit "head-sig.ss" "head-unit.ss") (require scheme/unit "head-sig.ss" "head-unit.ss")
(define-values/invoke-unit/infer head@) (define-values/invoke-unit/infer head@)
(provide-signature-elements head^)) (provide-signature-elements head^)

19
collects/net/imap-unit.ss
View File

@ -141,8 +141,7 @@
(let ([info (imap-read (skip l 2) r)]) (let ([info (imap-read (skip l 2) r)])
(log "info: ~s\n" info) (log "info: ~s\n" info)
(info-handler info)) (info-handler info))
(when id (when id (loop))]
(loop))]
[(starts-with? l #"+ ") [(starts-with? l #"+ ")
(if (null? continuation-handler) (if (null? continuation-handler)
(error 'imap-send "unexpected continuation request: ~a" l) (error 'imap-send "unexpected continuation request: ~a" l)
@ -462,22 +461,19 @@
[(+) "+FLAGS.SILENT"] [(+) "+FLAGS.SILENT"]
[(-) "-FLAGS.SILENT"] [(-) "-FLAGS.SILENT"]
[(!) "FLAGS.SILENT"] [(!) "FLAGS.SILENT"]
[else (raise-type-error [else (raise-type-error 'imap-store
'imap-store "mode: '!, '+, or '-" mode)]) "mode: '!, '+, or '-" mode)])
(box (format "~a" flags))) (box (format "~a" flags)))
void))) void)))
(define (imap-copy imap msgs dest-mailbox) (define (imap-copy imap msgs dest-mailbox)
(no-expunges 'imap-copy imap) (no-expunges 'imap-copy imap)
(check-ok (check-ok
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) (imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void)))
void)))
(define (imap-append imap dest-mailbox msg) (define (imap-append imap dest-mailbox msg)
(no-expunges 'imap-append imap) (no-expunges 'imap-append imap)
(let ([msg (if (bytes? msg) (let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))])
msg
(string->bytes/utf-8 msg))])
(check-ok (check-ok
(imap-send imap (list "APPEND" (imap-send imap (list "APPEND"
dest-mailbox dest-mailbox
@ -496,8 +492,7 @@
(check-ok (imap-send imap (check-ok (imap-send imap
(list "LIST" "" mailbox) (list "LIST" "" mailbox)
(lambda (i) (lambda (i)
(when (and (pair? i) (when (and (pair? i) (tag-eq? (car i) 'LIST))
(tag-eq? (car i) 'LIST))
(set! exists? #t))))) (set! exists? #t)))))
exists?)) exists?))
@ -505,7 +500,7 @@
(check-ok (imap-send imap (list "CREATE" mailbox) void))) (check-ok (imap-send imap (list "CREATE" mailbox) void)))
(define (imap-get-hierarchy-delimiter imap) (define (imap-get-hierarchy-delimiter imap)
(let* ([result #f]) (let ([result #f])
(check-ok (check-ok
(imap-send imap (list "LIST" "" "") (imap-send imap (list "LIST" "" "")
(lambda (i) (lambda (i)

9
collects/net/imap.ss
View File

@ -1,5 +1,5 @@
(module imap mzscheme #lang scheme/base
(require mzlib/unit mzlib/contract "imap-sig.ss" "imap-unit.ss") (require scheme/unit scheme/contract "imap-sig.ss" "imap-unit.ss")
(define-values/invoke-unit/infer imap@) (define-values/invoke-unit/infer imap@)
@ -7,7 +7,8 @@
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)] [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
[imap-list-child-mailboxes [imap-list-child-mailboxes
(case-> (case->
(imap-connection? (or/c false/c bytes?) . -> . (listof (list/c (listof symbol?) bytes?))) (imap-connection? (or/c false/c bytes?)
. -> . (listof (list/c (listof symbol?) bytes?)))
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?) (imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
. -> . . -> .
(listof (list/c (listof symbol?) bytes?))))]) (listof (list/c (listof symbol?) bytes?))))])
@ -46,4 +47,4 @@
imap-mailbox-exists? imap-mailbox-exists?
imap-create-mailbox imap-create-mailbox
imap-mailbox-flags)) imap-mailbox-flags)

7
collects/net/mime-sig.ss
View File

@ -12,16 +12,13 @@
;; -- basic mime structures -- ;; -- basic mime structures --
(struct message (version entity fields)) (struct message (version entity fields))
(struct entity (struct entity (type subtype charset encoding
(type subtype charset encoding
disposition params id disposition params id
description other fields description other fields
parts body)) parts body))
(struct disposition (struct disposition (type filename creation
(type filename creation
modification read modification read
size params)) size params))
;; -- mime methods -- ;; -- mime methods --
mime-analyze mime-analyze

35
collects/net/mime-unit.ss
View File

@ -34,9 +34,7 @@
"base64-sig.ss" "base64-sig.ss"
"head-sig.ss" "head-sig.ss"
"mime-util.ss" "mime-util.ss"
mzlib/etc scheme/port)
mzlib/string
mzlib/port)
(import base64^ qp^ head^) (import base64^ qp^ head^)
(export mime^) (export mime^)
@ -212,8 +210,7 @@
(lambda (output) (lambda (output)
(copy-port input output))]))) (copy-port input output))])))
(define mime-analyze (define (mime-analyze input [part #f])
(opt-lambda (input (part #f))
(let* ([iport (if (bytes? input) (let* ([iport (if (bytes? input)
(open-input-bytes input) (open-input-bytes input)
input)] input)]
@ -242,7 +239,7 @@
;; Unrecognized type, you're on your own! (sorry) ;; Unrecognized type, you're on your own! (sorry)
(mime-decode entity iport)]) (mime-decode entity iport)])
;; return mime structure ;; return mime structure
msg))) msg))
(define (entity-boundary entity) (define (entity-boundary entity)
(let* ([params (entity-params entity)] (let* ([params (entity-params entity)]
@ -357,8 +354,8 @@
fields)) fields))
(values mime non-mime)))) (values mime non-mime))))
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f)))) (define re:content #rx"^(?i:content-)")
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f)))) (define re:mime #rx"^(?i:mime-version):")
(define (mime-header? h) (define (mime-header? h)
(or (regexp-match? re:content h) (or (regexp-match? re:content h)
@ -370,8 +367,7 @@
;; *(";" parameter) ;; *(";" parameter)
;; ; Matching of media type and subtype ;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive. ;; ; is ALWAYS case-insensitive.
(define re:content-type (define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$")
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define (content header entity) (define (content header entity)
(let* ([params (string-tokenizer #\; header)] (let* ([params (string-tokenizer #\; header)]
[one re:content-type] [one re:content-type]
@ -394,9 +390,7 @@
(cond [par-pair (cond [par-pair
(when (string=? (car par-pair) "charset") (when (string=? (car par-pair) "charset")
(set-entity-charset! entity (cdr par-pair))) (set-entity-charset! entity (cdr par-pair)))
(loop (cdr p) (loop (cdr p) (append ans (list par-pair)))]
(append ans
(list par-pair)))]
[else [else
(warning "Invalid parameter for Content-Type: `~a'" (car p)) (warning "Invalid parameter for Content-Type: `~a'" (car p))
;; go on... ;; go on...
@ -406,7 +400,7 @@
;; disposition := "Content-Disposition" ":" ;; disposition := "Content-Disposition" ":"
;; disposition-type ;; disposition-type
;; *(";" disposition-parm) ;; *(";" disposition-parm)
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f)))) (define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
(define (dispositione header entity) (define (dispositione header entity)
(let* ([params (string-tokenizer #\; header)] (let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition] [reg re:content-disposition]
@ -420,8 +414,7 @@
(disp-params (cdr params) disp-struct)))) (disp-params (cdr params) disp-struct))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version (define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$")
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define (version header message) (define (version header message)
(let* ([reg re:mime-version] (let* ([reg re:mime-version]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
@ -432,8 +425,7 @@
(string->number (regexp-replace reg h "\\1.\\2")))))) (string->number (regexp-replace reg h "\\1.\\2"))))))
;; description := "Content-Description" ":" *text ;; description := "Content-Description" ":" *text
(define re:content-description (define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$")
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define (description header entity) (define (description header entity)
(let* ([reg re:content-description] (let* ([reg re:content-description]
[target (regexp-match reg header)]) [target (regexp-match reg header)])
@ -443,7 +435,7 @@
(trim-spaces (regexp-replace reg header "\\1")))))) (trim-spaces (regexp-replace reg header "\\1"))))))
;; encoding := "Content-Transfer-Encoding" ":" mechanism ;; encoding := "Content-Transfer-Encoding" ":" mechanism
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f)))) (define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$")
(define (encoding header entity) (define (encoding header entity)
(let* ([reg re:content-transfer-encoding] (let* ([reg re:content-transfer-encoding]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
@ -454,7 +446,7 @@
(mechanism (regexp-replace reg h "\\1")))))) (mechanism (regexp-replace reg h "\\1"))))))
;; id := "Content-ID" ":" msg-id ;; id := "Content-ID" ":" msg-id
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f)))) (define re:content-id #rx"^(?i:content-id):(.+)$")
(define (id header entity) (define (id header entity)
(let* ([reg re:content-id] (let* ([reg re:content-id]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
@ -502,8 +494,7 @@
(set-entity-other! (set-entity-other!
entity entity
(append (entity-other entity) (append (entity-other entity)
(list (list (cons (regexp-replace reg header "\\1")
(cons (regexp-replace reg header "\\1")
(trim-spaces (regexp-replace reg header "\\2"))))))))) (trim-spaces (regexp-replace reg header "\\2")))))))))
;; type := discrete-type / composite-type ;; type := discrete-type / composite-type

13
collects/net/mime-util.ss
View File

@ -26,8 +26,7 @@
;; ;;
;; Commentary: ;; Commentary:
(module mime-util mzscheme #lang scheme/base
(require mzlib/etc)
(provide string-tokenizer (provide string-tokenizer
trim-all-spaces trim-all-spaces
@ -52,8 +51,7 @@
(if (string=? s "") '() (if (string=? s "") '()
(let ([i (string-index s c)]) (let ([i (string-index s c)])
(if i (cons (substring s 0 i) (if i (cons (substring s 0 i)
(loop (substring s (+ i 1) (loop (substring s (+ i 1) (string-length s))))
(string-length s))))
(list s)))))) (list s))))))
;; Trim all spaces, except those in quoted strings. ;; Trim all spaces, except those in quoted strings.
@ -129,13 +127,10 @@
;; Copies its input `in' to its ouput port if given, it uses ;; Copies its input `in' to its ouput port if given, it uses
;; current-output-port if out is not provided. ;; current-output-port if out is not provided.
(define cat (define (cat in [out (current-output-port)])
(opt-lambda (in (out (current-output-port)))
(let loop ([ln (read-line in)]) (let loop ([ln (read-line in)])
(unless (eof-object? ln) (unless (eof-object? ln)
(fprintf out "~a\n" ln) (fprintf out "~a\n" ln)
(loop (read-line in)))))) (loop (read-line in)))))
)
;;; mime-util.ss ends here ;;; mime-util.ss ends here

6
collects/net/mime.ss
View File

@ -26,8 +26,8 @@
;; ;;
;; Commentary: ;; Commentary:
(module mime mzscheme #lang scheme/base
(require mzlib/unit (require scheme/unit
"mime-sig.ss" "mime-sig.ss"
"mime-unit.ss" "mime-unit.ss"
"qp-sig.ss" "qp-sig.ss"
@ -46,6 +46,6 @@
(define-values/invoke-unit/infer mime@2) (define-values/invoke-unit/infer mime@2)
(provide-signature-elements mime^)) (provide-signature-elements mime^)
;;; mime.ss ends here ;;; mime.ss ends here

6
collects/net/nntp.ss
View File

@ -1,6 +1,6 @@
(module nntp mzscheme #lang scheme/base
(require mzlib/unit "nntp-sig.ss" "nntp-unit.ss") (require scheme/unit "nntp-sig.ss" "nntp-unit.ss")
(define-values/invoke-unit/infer nntp@) (define-values/invoke-unit/infer nntp@)
(provide-signature-elements nntp^)) (provide-signature-elements nntp^)

6
collects/net/pop3.ss
View File

@ -1,9 +1,9 @@
(module pop3 mzscheme #lang scheme/base
(require mzlib/unit "pop3-sig.ss" "pop3-unit.ss") (require scheme/unit "pop3-sig.ss" "pop3-unit.ss")
(define-values/invoke-unit/infer pop3@) (define-values/invoke-unit/infer pop3@)
(provide-signature-elements pop3^)) (provide-signature-elements pop3^)
#| #|

40
collects/net/qp-unit.ss
View File

@ -28,8 +28,7 @@
#lang scheme/unit #lang scheme/unit
(require "qp-sig.ss" (require "qp-sig.ss")
mzlib/etc)
(import) (import)
(export qp^) (export qp^)
@ -42,22 +41,19 @@
;; qp-encode : bytes -> bytes ;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of STR. ;; returns the quoted printable representation of STR.
(define qp-encode (define (qp-encode str)
(lambda (str)
(let ([out (open-output-bytes)]) (let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n") (qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out)))) (get-output-bytes out)))
;; qp-decode : string -> string ;; qp-decode : string -> string
;; returns STR unqp. ;; returns STR unqp.
(define qp-decode (define (qp-decode str)
(lambda (str)
(let ([out (open-output-bytes)]) (let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out) (qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out)))) (get-output-bytes out)))
(define qp-decode-stream (define (qp-decode-stream in out)
(lambda (in out)
(let loop ([ch (read-byte in)]) (let loop ([ch (read-byte in)])
(unless (eof-object? ch) (unless (eof-object? ch)
(case ch (case ch
@ -98,33 +94,27 @@
(loop (read-byte in)))] (loop (read-byte in)))]
[else [else
(write-byte ch out) (write-byte ch out)
(loop (read-byte in))]))))) (loop (read-byte in))]))))
(define warning (define (warning msg . args)
(lambda (msg . args)
(when #f (when #f
(fprintf (current-error-port) (fprintf (current-error-port)
(apply format msg args)) (apply format msg args))
(newline (current-error-port))))) (newline (current-error-port))))
(define (hex-digit? i) (define (hex-digit? i)
(vector-ref hex-values i)) (vector-ref hex-values i))
(define hex-bytes->byte (define (hex-bytes->byte b1 b2)
(lambda (b1 b2)
(+ (* 16 (vector-ref hex-values b1)) (+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2)))) (vector-ref hex-values b2)))
(define write-hex-bytes (define (write-hex-bytes byte p)
(lambda (byte p)
(write-byte 61 p) (write-byte 61 p)
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p) (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))) (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))
(define re:blanks #rx#"[ \t]+$") (define (qp-encode-stream in out [newline-string #"\n"])
(define qp-encode-stream
(opt-lambda (in out [newline-string #"\n"])
(let loop ([col 0]) (let loop ([col 0])
(if (= col 75) (if (= col 75)
(begin (begin
@ -155,7 +145,7 @@
[else [else
;; an octect ;; an octect
(write-hex-bytes i out) (write-hex-bytes i out)
(loop (+ col 3))])))))) (loop (+ col 3))])))))
;; Tables ;; Tables
(define hex-values (make-vector 256 #f)) (define hex-values (make-vector 256 #f))

4
collects/net/qp.ss
View File

@ -26,11 +26,11 @@
;; ;;
;; Commentary: ;; Commentary:
(module qp mzscheme #lang scheme/base
(require mzlib/unit "qp-sig.ss" "qp-unit.ss") (require mzlib/unit "qp-sig.ss" "qp-unit.ss")
(define-values/invoke-unit/infer qp@) (define-values/invoke-unit/infer qp@)
(provide-signature-elements qp^)) (provide-signature-elements qp^)
;;; qp.ss ends here ;;; qp.ss ends here

12
collects/net/sendmail-unit.ss
View File

@ -39,8 +39,8 @@
;; the port returned by this procedure as soon as the necessary text ;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete. ;; has been written, so that the sendmail process can complete.
(define send-mail-message/port (define (send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients sender subject to-recipients cc-recipients bcc-recipients
. other-headers) . other-headers)
(when (and (null? to-recipients) (null? cc-recipients) (when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients)) (null? bcc-recipients))
@ -94,7 +94,7 @@
(newline writer)) (newline writer))
other-headers) other-headers)
(newline writer) (newline writer)
writer)))) writer)))
;; send-mail-message : ;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x ;; string x string x list (string) x list (string) x list (string) x
@ -106,8 +106,8 @@
;; RFC conventions. If any other headers are specified, they are ;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already. ;; expected to be completely formatted already.
(define send-mail-message (define (send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text sender subject to-recipients cc-recipients bcc-recipients text
. other-headers) . other-headers)
(let ([writer (apply send-mail-message/port sender subject (let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients to-recipients cc-recipients bcc-recipients
@ -116,4 +116,4 @@
(display s writer) ; We use -i, so "." is not a problem (display s writer) ; We use -i, so "." is not a problem
(newline writer)) (newline writer))
text) text)
(close-output-port writer)))) (close-output-port writer)))

6
collects/net/sendmail.ss
View File

@ -1,6 +1,6 @@
(module sendmail mzscheme #lang scheme/base
(require mzlib/unit "sendmail-sig.ss" "sendmail-unit.ss") (require scheme/unit "sendmail-sig.ss" "sendmail-unit.ss")
(define-values/invoke-unit/infer sendmail@) (define-values/invoke-unit/infer sendmail@)
(provide-signature-elements sendmail^)) (provide-signature-elements sendmail^)

6
collects/net/smtp.ss
View File

@ -1,6 +1,6 @@
(module smtp mzscheme #lang scheme/base
(require mzlib/unit "smtp-sig.ss" "smtp-unit.ss") (require scheme/unit "smtp-sig.ss" "smtp-unit.ss")
(define-values/invoke-unit/infer smtp@) (define-values/invoke-unit/infer smtp@)
(provide-signature-elements smtp^)) (provide-signature-elements smtp^)

24
collects/net/ssl-tcp-unit.ss
View File

@ -1,9 +1,8 @@
(module ssl-tcp-unit mzscheme #lang scheme/base
(provide make-ssl-tcp@) (provide make-ssl-tcp@)
(require mzlib/unit (require scheme/unit
"tcp-sig.ss" "tcp-sig.ss"
(lib "mzssl.ss" "openssl") openssl/mzssl)
mzlib/etc)
(define (make-ssl-tcp@ (define (make-ssl-tcp@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
@ -37,15 +36,12 @@
(define tcp-addresses ssl-addresses) (define tcp-addresses ssl-addresses)
(define tcp-close ssl-close) (define tcp-close ssl-close)
(define tcp-connect (define (tcp-connect hostname port-k)
(opt-lambda (hostname port-k) (ssl-connect hostname port-k ctx))
(ssl-connect hostname port-k ctx))) (define (tcp-connect/enable-break hostname port-k)
(define tcp-connect/enable-break (ssl-connect/enable-break hostname port-k ctx))
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define tcp-listen (define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)]) (let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file (when server-cert-file
(ssl-load-certificate-chain! l server-cert-file)) (ssl-load-certificate-chain! l server-cert-file))
@ -58,6 +54,6 @@
server-root-cert-files)) server-root-cert-files))
(when server-suggest-auth-file (when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file)) (ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l))) l))
(define tcp-listener? ssl-listener?)))) (define tcp-listener? ssl-listener?)))

85
collects/net/tcp-redirect.ss
View File

@ -1,9 +1,9 @@
(module tcp-redirect mzscheme #lang scheme/base
(provide tcp-redirect) (provide tcp-redirect)
(require mzlib/unit (require scheme/unit
mzlib/async-channel scheme/tcp
mzlib/etc scheme/async-channel
"tcp-sig.ss") "tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-abandon-port tcp-abandon-port)
@ -17,25 +17,24 @@
(define raw:tcp-listen tcp-listen) (define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?) (define raw:tcp-listener? tcp-listener?)
; For tcp-listeners, we use an else branch in the conds since ;; For tcp-listeners, we use an else branch in the conds since
; (instead of a contract) I want the same error message as the raw ;; (instead of a contract) I want the same error message as the raw
; primitive for bad inputs. ;; primitive for bad inputs.
; : (listof nat) -> (unit/sig () -> net:tcp^) ;; : (listof nat) -> (unit/sig () -> net:tcp^)
(define tcp-redirect (define (tcp-redirect redirected-ports [redirected-address "127.0.0.1"])
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
(unit (unit
(import) (import)
(export tcp^) (export tcp^)
; : (make-pipe-listener nat (channel (cons iport oport))) ;; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel)) (define-struct pipe-listener (port channel))
; : port -> void ;; : port -> void
(define (tcp-abandon-port tcp-port) (define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port) (when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port))) (raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport ;; : listener -> iport oport
(define (tcp-accept tcp-listener) (define (tcp-accept tcp-listener)
(cond (cond
[(pipe-listener? tcp-listener) [(pipe-listener? tcp-listener)
@ -43,11 +42,11 @@
(values (car in-out) (cdr in-out)))] (values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)])) [else (raw:tcp-accept tcp-listener)]))
; : listener -> iport oport ;; : listener -> iport oport
(define (tcp-accept/enable-break tcp-listener) (define (tcp-accept/enable-break tcp-listener)
(cond (cond
[(pipe-listener? tcp-listener) [(pipe-listener? tcp-listener)
; XXX put this into async-channel.ss as async-channel-get/enable-break ;; XXX put this into async-channel.ss as async-channel-get/enable-break
(sync/enable-break (sync/enable-break
(handle-evt (handle-evt
(pipe-listener-channel tcp-listener) (pipe-listener-channel tcp-listener)
@ -57,28 +56,26 @@
(values (car in-out) (cdr in-out))) (values (car in-out) (cdr in-out)))
[else (raw:tcp-accept/enable-break tcp-listener)])) [else (raw:tcp-accept/enable-break tcp-listener)]))
; : tcp-listener -> iport oport ;; : tcp-listener -> iport oport
; FIX - check channel queue size ;; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener) (define (tcp-accept-ready? tcp-listener)
(cond (cond
[(pipe-listener? tcp-listener) #t] [(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)])) [else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-port -> str str ;; : tcp-port -> str str
(define (tcp-addresses tcp-port) (define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port) (if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port) (raw:tcp-addresses tcp-port)
(values redirected-address redirected-address))) (values redirected-address redirected-address)))
; : port -> void ;; : port -> void
(define (tcp-close tcp-listener) (define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener) (if (tcp-listener? tcp-listener)
(raw:tcp-close tcp-listener) (raw:tcp-close tcp-listener)
(hash-table-remove! (hash-remove! port-table (pipe-listener-port tcp-listener))))
port-table
(pipe-listener-port tcp-listener))))
; : (str nat -> iport oport) -> str nat -> iport oport ;; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw) (define (gen-tcp-connect raw)
(lambda (hostname-string port) (lambda (hostname-string port)
(if (and (string=? redirected-address hostname-string) (if (and (string=? redirected-address hostname-string)
@ -87,9 +84,7 @@
[(from-in to-out) (make-pipe)]) [(from-in to-out) (make-pipe)])
(async-channel-put (async-channel-put
(pipe-listener-channel (pipe-listener-channel
(hash-table-get (hash-ref port-table port
port-table
port
(lambda () (lambda ()
(raise (make-exn:fail:network (raise (make-exn:fail:network
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)" (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
@ -99,40 +94,40 @@
(values from-in from-out)) (values from-in from-out))
(raw hostname-string port)))) (raw hostname-string port))))
; : str nat -> iport oport ;; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect)) (define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport ;; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break)) (define tcp-connect/enable-break
(gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag. ;; FIX - support the reuse? flag.
(define tcp-listen (define (tcp-listen port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f]) (hash-ref port-table port
(hash-table-get
port-table
port
(lambda () (lambda ()
(if (redirect? port) (if (redirect? port)
(let ([listener (make-pipe-listener port (make-async-channel))]) (let ([listener (make-pipe-listener port (make-async-channel))])
(hash-table-put! port-table port listener) (hash-set! port-table port listener)
listener) listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string)))))) (raw:tcp-listen port max-allow-wait reuse? hostname-string)))))
; : tst -> bool ;; : tst -> bool
(define (tcp-listener? x) (define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x))) (or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ---------- ;; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener) ;; : (hash nat[port] -> tcp-listener)
(define port-table (make-hash-table)) (define port-table (make-hasheq))
(define redirect-table (define redirect-table
(let ([table (make-hash-table)]) (let ([table (make-hasheq)])
(for-each (lambda (x) (hash-table-put! table x #t)) (for-each (lambda (x) (hash-set! table x #t))
redirected-ports) redirected-ports)
table)) table))
; : nat -> bool ;; : nat -> bool
(define (redirect? port) (define (redirect? port)
(hash-table-get redirect-table port (lambda () #f))))))) (hash-ref redirect-table port #f))
))

6
collects/net/tcp-unit.ss
View File

@ -1,6 +1,6 @@
(module tcp-unit mzscheme #lang scheme/base
(provide tcp@) (provide tcp@)
(require mzlib/unit "tcp-sig.ss") (require scheme/unit scheme/tcp "tcp-sig.ss")
(define-unit-from-context tcp@ tcp^)) (define-unit-from-context tcp@ tcp^)

4
collects/net/unihead.ss
View File

@ -1,4 +1,4 @@
(module unihead mzscheme #lang mzscheme
(require net/base64 (require net/base64
net/qp net/qp
mzlib/string) mzlib/string)
@ -115,4 +115,4 @@
(subbytes rest 3) (subbytes rest 3)
rest)]) rest)])
(decode-for-header (bytes->string/latin-1 rest)))))) (decode-for-header (bytes->string/latin-1 rest))))))
s))))) s))))

4
collects/net/uri-codec.ss
View File

@ -1,6 +1,6 @@
(module uri-codec mzscheme #lang scheme/base
(require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss") (require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss")
(provide-signature-elements uri-codec^) (provide-signature-elements uri-codec^)
(define-values/invoke-unit/infer uri-codec@)) (define-values/invoke-unit/infer uri-codec@)

12
collects/net/url-structs.ss
View File

@ -1,8 +1,10 @@
(module url-structs mzscheme #lang scheme/base
(require mzlib/contract (require scheme/contract
mzlib/serialize) scheme/serialize)
(define-serializable-struct url (scheme user host port path-absolute? path query fragment)) (define-serializable-struct url
(scheme user host port path-absolute? path query fragment)
#:mutable)
(define-serializable-struct path/param (path param)) (define-serializable-struct path/param (path param))
(provide/contract (provide/contract
@ -15,4 +17,4 @@
[query (listof (cons/c symbol? (or/c string? false/c)))] [query (listof (cons/c symbol? (or/c string? false/c)))]
[fragment (or/c false/c string?)])) [fragment (or/c false/c string?)]))
(struct path/param ([path (or/c string? (symbols 'up 'same))] (struct path/param ([path (or/c string? (symbols 'up 'same))]
[param (listof string?)])))) [param (listof string?)])))

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

@ -9,20 +9,13 @@
;; "impure" = they have text waiting ;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read ;; "pure" = the MIME headers have been read
(module url-unit scheme/base #lang scheme/unit
(require mzlib/file (require scheme/port
mzlib/unit
mzlib/port
mzlib/list
mzlib/string
mzlib/kw
"url-structs.ss" "url-structs.ss"
"uri-codec.ss" "uri-codec.ss"
"url-sig.ss" "url-sig.ss"
"tcp-sig.ss") "tcp-sig.ss")
(provide url@)
(define-unit url@
(import tcp^) (import tcp^)
(export url^) (export url^)
@ -179,19 +172,18 @@
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") [(or (string=? scheme "http") (string=? scheme "https"))
(string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)] (http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file") [(string=? scheme "file")
(url-error "There are no impure file: ports")] (url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)]))) [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/kw (get-impure-port url #:optional [strings '()]) (define (get-impure-port url [strings '()])
(getpost-impure-port #t url #f strings)) (getpost-impure-port #t url #f strings))
;; post-impure-port : url x bytes [x list (str)] -> in-port ;; post-impure-port : url x bytes [x list (str)] -> in-port
(define/kw (post-impure-port url post-data #:optional [strings '()]) (define (post-impure-port url post-data [strings '()])
(getpost-impure-port #f 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
@ -213,11 +205,11 @@
[else (url-error "Scheme ~a unsupported" scheme)]))) [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/kw (get-pure-port url #:optional [strings '()]) (define (get-pure-port url [strings '()])
(getpost-pure-port #t url #f strings)) (getpost-pure-port #t url #f strings))
;; post-pure-port : url bytes [x list (str)] -> in-port ;; post-pure-port : url bytes [x list (str)] -> in-port
(define/kw (post-pure-port url post-data #:optional [strings '()]) (define (post-pure-port url post-data [strings '()])
(getpost-pure-port #f url post-data strings)) (getpost-pure-port #f url post-data strings))
;; display-pure-port : in-port -> () ;; display-pure-port : in-port -> ()
@ -378,8 +370,7 @@
scheme))) scheme)))
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str)) (url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path ;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(let ([win-file? (and (or (equal? "" port) (let ([win-file? (and (or (equal? "" port) (not port))
(not port))
(equal? "file" scheme) (equal? "file" scheme)
(eq? 'windows (file-url-path-convention-type)) (eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))]) (not (equal? host "")))])
@ -457,7 +448,8 @@
(loop (cdr strings) (list* (car strings) sep r))))])) (loop (cdr strings) (list* (car strings) sep r))))]))
(define (path->url path) (define (path->url path)
(let ([url-path (let loop ([path (simplify-path path #f)][accum null]) (let ([url-path
(let loop ([path (simplify-path path #f)][accum null])
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(cond (cond
[(not base) [(not base)
@ -468,8 +460,7 @@
;; For Windows, massage the root: ;; For Windows, massage the root:
(let ([s (regexp-replace (let ([s (regexp-replace
#rx"[/\\\\]$" #rx"[/\\\\]$"
(bytes->string/utf-8 (bytes->string/utf-8 (path->bytes name))
(path->bytes name))
"")]) "")])
(cond (cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
@ -503,27 +494,27 @@
(file://->path url kind)) (file://->path url kind))
;; delete-pure-port : url [x list (str)] -> in-port ;; delete-pure-port : url [x list (str)] -> in-port
(define/kw (delete-pure-port url #:optional [strings '()]) (define (delete-pure-port url [strings '()])
(method-pure-port 'delete url #f strings)) (method-pure-port 'delete url #f strings))
;; delete-impure-port : url [x list (str)] -> in-port ;; delete-impure-port : url [x list (str)] -> in-port
(define/kw (delete-impure-port url #:optional [strings '()]) (define (delete-impure-port url [strings '()])
(method-impure-port 'delete url #f strings)) (method-impure-port 'delete url #f strings))
;; head-pure-port : url [x list (str)] -> in-port ;; head-pure-port : url [x list (str)] -> in-port
(define/kw (head-pure-port url #:optional [strings '()]) (define (head-pure-port url [strings '()])
(method-pure-port 'head url #f strings)) (method-pure-port 'head url #f strings))
;; head-impure-port : url [x list (str)] -> in-port ;; head-impure-port : url [x list (str)] -> in-port
(define/kw (head-impure-port url #:optional [strings '()]) (define (head-impure-port url [strings '()])
(method-impure-port 'head url #f strings)) (method-impure-port 'head url #f strings))
;; put-pure-port : url bytes [x list (str)] -> in-port ;; put-pure-port : url bytes [x list (str)] -> in-port
(define/kw (put-pure-port url put-data #:optional [strings '()]) (define (put-pure-port url put-data [strings '()])
(method-pure-port 'put url put-data strings)) (method-pure-port 'put url put-data strings))
;; put-impure-port : url x bytes [x list (str)] -> in-port ;; put-impure-port : url x bytes [x list (str)] -> in-port
(define/kw (put-impure-port url put-data #:optional [strings '()]) (define (put-impure-port url put-data [strings '()])
(method-impure-port 'put url put-data strings)) (method-impure-port 'put url put-data strings))
;; method-impure-port : symbol x url x list (str) -> in-port ;; method-impure-port : symbol x url x list (str) -> in-port
@ -531,8 +522,7 @@
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") [(or (string=? scheme "http") (string=? scheme "https"))
(string=? scheme "https"))
(http://method-impure-port method url data strings)] (http://method-impure-port method url data strings)]
[(string=? scheme "file") [(string=? scheme "file")
(url-error "There are no impure file: ports")] (url-error "There are no impure file: ports")]
@ -543,8 +533,7 @@
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") [(or (string=? scheme "http") (string=? scheme "https"))
(string=? scheme "https"))
(let ([port (http://method-impure-port (let ([port (http://method-impure-port
method url data strings)]) method url data strings)])
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
@ -586,5 +575,3 @@
(flush-output client->server) (flush-output client->server)
(tcp-abandon-port client->server) (tcp-abandon-port client->server)
server->client)) server->client))
))

20
collects/net/url.ss
View File

@ -1,6 +1,7 @@
(module url mzscheme #lang scheme/base
(require mzlib/unit (require scheme/unit
mzlib/contract scheme/contract
(only-in mzlib/contract opt->)
"url-structs.ss" "url-structs.ss"
"url-sig.ss" "url-sig.ss"
"url-unit.ss" "url-unit.ss"
@ -13,16 +14,7 @@
(define-values/invoke-unit/infer url+tcp@) (define-values/invoke-unit/infer url+tcp@)
(provide (provide (struct-out url) (struct-out path/param))
(struct url (scheme
user
host
port
path-absolute?
path
query
fragment))
(struct path/param (path param)))
(provide/contract (provide/contract
(string->url ((or/c bytes? string?) . -> . url?)) (string->url ((or/c bytes? string?) . -> . url?))
@ -59,5 +51,3 @@
(parameter/c (or/c false/c (listof (list/c string? string? number?))))) (parameter/c (or/c false/c (listof (list/c string? string? number?)))))
(file-url-path-convention-type (file-url-path-convention-type
(parameter/c (one-of/c 'unix 'windows)))) (parameter/c (one-of/c 'unix 'windows))))
)