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
base64-filename-safe

8
collects/net/base64.ss
View File

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

6
collects/net/cgi.ss
View File

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

6
collects/net/cookie.ss
View File

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

6
collects/net/dns.ss
View File

@ -1,6 +1,6 @@
(module dns mzscheme
(require mzlib/unit "dns-sig.ss" "dns-unit.ss")
#lang scheme/base
(require scheme/unit "dns-sig.ss" "dns-unit.ss")
(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
(require mzlib/unit "ftp-sig.ss" "ftp-unit.ss")
#lang scheme/base
(require scheme/unit "ftp-sig.ss" "ftp-unit.ss")
(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:
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header)
(if (bytes? header)
(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)))
(if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
(if m
(let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))]
@ -242,9 +240,7 @@
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(if (< (caar mq1) (caar mq2)) mq1 mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))

6
collects/net/head.ss
View File

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

9
collects/net/imap.ss
View File

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

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

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

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

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

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

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

6
collects/net/mime.ss
View File

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

6
collects/net/nntp.ss
View File

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

4
collects/net/qp.ss
View File

@ -26,11 +26,11 @@
;;
;; Commentary:
(module qp mzscheme
#lang scheme/base
(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
(define-values/invoke-unit/infer qp@)
(provide-signature-elements qp^))
(provide-signature-elements qp^)
;;; 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
;; has been written, so that the sendmail process can complete.
(define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients
(define (send-mail-message/port
sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
@ -94,7 +94,7 @@
(newline writer))
other-headers)
(newline writer)
writer))))
writer)))
;; send-mail-message :
;; 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
;; expected to be completely formatted already.
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
(define (send-mail-message
sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
@ -116,4 +116,4 @@
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer))))
(close-output-port writer)))

6
collects/net/sendmail.ss
View File

@ -1,6 +1,6 @@
(module sendmail mzscheme
(require mzlib/unit "sendmail-sig.ss" "sendmail-unit.ss")
#lang scheme/base
(require scheme/unit "sendmail-sig.ss" "sendmail-unit.ss")
(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
(require mzlib/unit "smtp-sig.ss" "smtp-unit.ss")
#lang scheme/base
(require scheme/unit "smtp-sig.ss" "smtp-unit.ss")
(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@)
(require mzlib/unit
(require scheme/unit
"tcp-sig.ss"
(lib "mzssl.ss" "openssl")
mzlib/etc)
openssl/mzssl)
(define (make-ssl-tcp@
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-close ssl-close)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define (tcp-connect hostname port-k)
(ssl-connect hostname port-k ctx))
(define (tcp-connect/enable-break hostname port-k)
(ssl-connect/enable-break hostname port-k ctx))
(define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
@ -58,6 +54,6 @@
server-root-cert-files))
(when 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)
(require mzlib/unit
mzlib/async-channel
mzlib/etc
(require scheme/unit
scheme/tcp
scheme/async-channel
"tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port)
@ -17,25 +17,24 @@
(define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?)
; 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
; primitive for bad inputs.
;; 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
;; primitive for bad inputs.
; : (listof nat) -> (unit/sig () -> net:tcp^)
(define tcp-redirect
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
;; : (listof nat) -> (unit/sig () -> net:tcp^)
(define (tcp-redirect redirected-ports [redirected-address "127.0.0.1"])
(unit
(import)
(export tcp^)
; : (make-pipe-listener nat (channel (cons iport oport)))
;; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel))
; : port -> void
;; : port -> void
(define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport
;; : listener -> iport oport
(define (tcp-accept tcp-listener)
(cond
[(pipe-listener? tcp-listener)
@ -43,11 +42,11 @@
(values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)]))
; : listener -> iport oport
;; : listener -> iport oport
(define (tcp-accept/enable-break tcp-listener)
(cond
[(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
(handle-evt
(pipe-listener-channel tcp-listener)
@ -57,28 +56,26 @@
(values (car in-out) (cdr in-out)))
[else (raw:tcp-accept/enable-break tcp-listener)]))
; : tcp-listener -> iport oport
; FIX - check channel queue size
;; : tcp-listener -> iport oport
;; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener)
(cond
[(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-port -> str str
;; : tcp-port -> str str
(define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port)
(values redirected-address redirected-address)))
; : port -> void
;; : port -> void
(define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener)
(raw:tcp-close tcp-listener)
(hash-table-remove!
port-table
(pipe-listener-port tcp-listener))))
(hash-remove! 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)
(lambda (hostname-string port)
(if (and (string=? redirected-address hostname-string)
@ -87,9 +84,7 @@
[(from-in to-out) (make-pipe)])
(async-channel-put
(pipe-listener-channel
(hash-table-get
port-table
port
(hash-ref port-table port
(lambda ()
(raise (make-exn:fail:network
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
@ -99,40 +94,40 @@
(values from-in from-out))
(raw hostname-string port))))
; : str nat -> iport oport
;; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
;; : str nat -> iport oport
(define tcp-connect/enable-break
(gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag.
(define tcp-listen
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(hash-table-get
port-table
port
;; FIX - support the reuse? flag.
(define (tcp-listen port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(hash-ref port-table port
(lambda ()
(if (redirect? port)
(let ([listener (make-pipe-listener port (make-async-channel))])
(hash-table-put! port-table port listener)
(hash-set! port-table port 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)
(or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ----------
;; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener)
(define port-table (make-hash-table))
;; : (hash nat[port] -> tcp-listener)
(define port-table (make-hasheq))
(define redirect-table
(let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t))
(let ([table (make-hasheq)])
(for-each (lambda (x) (hash-set! table x #t))
redirected-ports)
table))
; : nat -> bool
;; : nat -> bool
(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@)
(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
net/qp
mzlib/string)
@ -115,4 +115,4 @@
(subbytes rest 3)
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")
(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
(require mzlib/contract
mzlib/serialize)
#lang scheme/base
(require scheme/contract
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))
(provide/contract
@ -15,4 +17,4 @@
[query (listof (cons/c symbol? (or/c string? false/c)))]
[fragment (or/c false/c string?)]))
(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
;; "pure" = the MIME headers have been read
(module url-unit scheme/base
(require mzlib/file
mzlib/unit
mzlib/port
mzlib/list
mzlib/string
mzlib/kw
#lang scheme/unit
(require scheme/port
"url-structs.ss"
"uri-codec.ss"
"url-sig.ss"
"tcp-sig.ss")
(provide url@)
(define-unit url@
(import tcp^)
(export url^)
@ -179,19 +172,18 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-impure-port : url [x list (str)] -> in-port
(define/kw (get-impure-port url #:optional [strings '()])
(define (get-impure-port url [strings '()])
(getpost-impure-port #t url #f strings))
;; 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-pure-port : bool x url x list (str) -> in-port
@ -213,11 +205,11 @@
[else (url-error "Scheme ~a unsupported" scheme)])))
;; 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))
;; 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))
;; display-pure-port : in-port -> ()
@ -378,8 +370,7 @@
scheme)))
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(let ([win-file? (and (or (equal? "" port)
(not port))
(let ([win-file? (and (or (equal? "" port) (not port))
(equal? "file" scheme)
(eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))])
@ -457,7 +448,8 @@
(loop (cdr strings) (list* (car strings) sep r))))]))
(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)])
(cond
[(not base)
@ -468,8 +460,7 @@
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8
(path->bytes name))
(bytes->string/utf-8 (path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
@ -503,27 +494,27 @@
(file://->path url kind))
;; 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))
;; 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))
;; 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))
;; 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))
;; 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))
;; 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 : symbol x url x list (str) -> in-port
@ -531,8 +522,7 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(http://method-impure-port method url data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
@ -543,8 +533,7 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(let ([port (http://method-impure-port
method url data strings)])
(with-handlers ([void (lambda (exn)
@ -586,5 +575,3 @@
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
))

20
collects/net/url.ss
View File

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