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

reformatting

Browse Source 
svn: r9853

original commit: 0d41afdb6d470299616dd1db944ce4577c5a64bf
This commit is contained in:
Eli Barzilay 2008-05-15 16:55:15 +00:00
parent db624416dd
commit ec81ffebfc
11 changed files with 2950 additions and 3011 deletions

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

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

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)

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

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]))

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)))

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)

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

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))

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)))

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))
))