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

formatting etc

Browse Source 
svn: r5045

original commit: f17f7bc479
This commit is contained in:
Eli Barzilay 2006-12-06 21:23:38 +00:00
parent e6fc4d4027
commit c276d448fe
19 changed files with 533 additions and 553 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/net/cgi.ss
View File

@ -1,7 +1,5 @@
(module cgi mzscheme (module cgi mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "cgi-sig.ss" "cgi-unit.ss")
"cgi-sig.ss"
"cgi-unit.ss")
(define-values/invoke-unit/infer cgi@) (define-values/invoke-unit/infer cgi@)

6
collects/net/cookie.ss
View File

@ -1,8 +1,6 @@
(module cookie mzscheme (module cookie mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "cookie-sig.ss" "cookie-unit.ss")
"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@))

4
collects/net/dns.ss
View File

@ -1,7 +1,5 @@
(module dns mzscheme (module dns mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "dns-sig.ss" "dns-unit.ss")
"dns-sig.ss"
"dns-unit.ss")
(define-values/invoke-unit/infer dns@) (define-values/invoke-unit/infer dns@)

4
collects/net/ftp.ss
View File

@ -1,7 +1,5 @@
(module ftp mzscheme (module ftp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "ftp-sig.ss" "ftp-unit.ss")
"ftp-sig.ss"
"ftp-unit.ss")
(define-values/invoke-unit/infer ftp@) (define-values/invoke-unit/infer ftp@)

23
collects/net/imap.ss
View File

@ -1,11 +1,8 @@
(module imap mzscheme (module imap mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") (lib "contract.ss") "imap-sig.ss" "imap-unit.ss")
(lib "contract.ss")
"imap-sig.ss"
"imap-unit.ss")
(define-values/invoke-unit/infer imap@) (define-values/invoke-unit/infer imap@)
(provide/contract (provide/contract
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)] [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
[imap-list-child-mailboxes [imap-list-child-mailboxes
@ -14,7 +11,7 @@
(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?))))])
(provide (provide
imap-connection? imap-connection?
imap-connect imap-connect* imap-connect imap-connect*
@ -25,7 +22,7 @@
imap-noop imap-noop
imap-poll imap-poll
imap-status imap-status
imap-port-number ; a parameter imap-port-number ; a parameter
imap-new? imap-new?
@ -35,18 +32,18 @@
imap-uidvalidity imap-uidvalidity
imap-unseen imap-unseen
imap-reset-new! imap-reset-new!
imap-get-expunges imap-get-expunges
imap-pending-expunges? imap-pending-expunges?
imap-get-updates imap-get-updates
imap-pending-updates? imap-pending-updates?
imap-get-messages imap-get-messages
imap-copy imap-append imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag imap-store imap-flag->symbol symbol->imap-flag
imap-expunge imap-expunge
imap-mailbox-exists? imap-mailbox-exists?
imap-create-mailbox imap-create-mailbox
imap-mailbox-flags)) imap-mailbox-flags))

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

@ -2,7 +2,7 @@
;;; <mime-util.ss> ---- Extra utilities ;;; <mime-util.ss> ---- Extra utilities
;;; Time-stamp: <01/05/07 17:41:12 solsona> ;;; Time-stamp: <01/05/07 17:41:12 solsona>
;;; ;;;
;;; Copyright (C) 2001 by Francisco Solsona. ;;; Copyright (C) 2001 by Francisco Solsona.
;;; ;;;
;;; This file is part of mime-plt. ;;; This file is part of mime-plt.
@ -40,22 +40,22 @@
;; that has character c ;; that has character c
(define string-index (define string-index
(lambda (s c) (lambda (s c)
(let ((n (string-length s))) (let ([n (string-length s)])
(let loop ((i 0)) (let loop ([i 0])
(cond ((>= i n) #f) (cond [(>= i n) #f]
((char=? (string-ref s i) c) i) [(char=? (string-ref s i) c) i]
(else (loop (+ i 1)))))))) [else (loop (+ i 1))])))))
;; string-tokenizer breaks string s into substrings separated by character c ;; string-tokenizer breaks string s into substrings separated by character c
(define string-tokenizer (define string-tokenizer
(lambda (c s) (lambda (c s)
(let loop ((s s)) (let loop ([s s])
(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.
(define re:quote-start (regexp "\"")) (define re:quote-start (regexp "\""))
@ -65,30 +65,30 @@
;; Break out alternate quoted and unquoted parts. ;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted. ;; Initial and final string are unquoted.
(let-values ([(unquoted quoted) (let-values ([(unquoted quoted)
(let loop ([str str][unquoted null][quoted null]) (let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)]) (let ([m (regexp-match-positions re:quote-start str)])
(if m (if m
(let ([prefix (substring str 0 (caar m))] (let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))]) [rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote ;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)]) (let ([m (regexp-match-positions re:quote-start rest)])
(if m (if m
(let ([inside (substring rest 0 (caar m))] (let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))]) [rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted))) (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote! ;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted))))) (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))]) (values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts: ;; Put the pieces back together, stripping spaces for unquoted parts:
(apply (apply
string-append string-append
(let loop ([unquoted unquoted][quoted quoted]) (let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")]) (let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted) (if (null? quoted)
(list clean) (list clean)
(list* clean (list* clean
(car quoted) (car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))) (loop (cdr unquoted) (cdr quoted))))))))))
;; Only trims left and right spaces: ;; Only trims left and right spaces:
(define trim-spaces (define trim-spaces
@ -108,39 +108,41 @@
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")) (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments (define trim-comments
(lambda (str) (lambda (str)
(let* ((positions (regexp-match-positions re:comments str))) (let ([positions (regexp-match-positions re:comments str)])
(if positions (if positions
(string-append (substring str 0 (caaddr positions)) (string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str))) (substring str (cdaddr positions) (string-length str)))
str)))) str))))
(define lowercase (define lowercase
(lambda (str) (lambda (str)
(let loop ((out "") (rest str) (size (string-length str))) (let loop ([out ""] [rest str] [size (string-length str)])
(cond ((zero? size) out) (cond [(zero? size) out]
(else [else
(loop (string-append out (string (loop (string-append out (string
(char-downcase (char-downcase
(string-ref rest 0)))) (string-ref rest 0))))
(substring rest 1 size) (substring rest 1 size)
(sub1 size))))))) (sub1 size))]))))
(define warning void) (define warning
#| void
#;
(lambda (msg . args) (lambda (msg . args)
(fprintf (current-error-port) (fprintf (current-error-port)
(apply format (cons msg args))) (apply format (cons msg args)))
(newline (current-error-port)))) (newline (current-error-port)))
|# )
;; 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
(opt-lambda (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

12
collects/net/mime.ss
View File

@ -1,8 +1,8 @@
;;; ;;;
;;; <mime.ss> ---- MIME support ;;; <mime.ss> ---- MIME support
;;; ;;;
;;; Copyright (C) 2002 by PLT. ;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing. ;;; Copyright (C) 2001 by Wish Computing.
;;; ;;;
;;; This file is part of mime ;;; This file is part of mime
@ -34,8 +34,8 @@
"qp.ss" "qp.ss"
"base64-sig.ss" "base64-sig.ss"
"base64.ss" "base64.ss"
"head-sig.ss" "head-sig.ss"
"head.ss") "head.ss")
(define-unit-from-context base64@ base64^) (define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^) (define-unit-from-context qp@ qp^)
@ -43,9 +43,9 @@
(define-compound-unit/infer mime@2 (import) (export mime^) (define-compound-unit/infer mime@2 (import) (export mime^)
(link base64@ qp@ head@ mime@)) (link base64@ qp@ head@ mime@))
(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

4
collects/net/nntp.ss
View File

@ -1,7 +1,5 @@
(module nntp mzscheme (module nntp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "nntp-sig.ss" "nntp-unit.ss")
"nntp-sig.ss"
"nntp-unit.ss")
(define-values/invoke-unit/infer nntp@) (define-values/invoke-unit/infer nntp@)

5
collects/net/pop3.ss
View File

@ -1,7 +1,5 @@
(module pop3 mzscheme (module pop3 mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "pop3-sig.ss" "pop3-unit.ss")
"pop3-sig.ss"
"pop3-unit.ss")
(define-values/invoke-unit/infer pop3@) (define-values/invoke-unit/infer pop3@)
@ -29,5 +27,4 @@
"Status: RO") "Status: RO")
("some body" "text" "goes" "." "here" "." "") ("some body" "text" "goes" "." "here" "." "")
> (disconnect-from-server c) > (disconnect-from-server c)
|# |#

382
collects/net/private/rbtree.ss
View File

@ -20,8 +20,8 @@
(module rbtree mzscheme (module rbtree mzscheme
(provide new-tree tree-empty? (provide new-tree tree-empty?
expunge-insert! expunge-tree->list expunge-insert! expunge-tree->list
fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list) fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
(define-struct tree (v red? left-count left right parent) (make-inspector)) (define-struct tree (v red? left-count left right parent) (make-inspector))
@ -33,167 +33,167 @@
(define (k+ a b) (define (k+ a b)
(cons (+ (car a) (if (number? b) b (car b))) (cons (+ (car a) (if (number? b) b (car b)))
(cdr a))) (cdr a)))
(define (k- a b) (define (k- a b)
(cons (- (car a) (if (number? b) b (car b))) (cons (- (car a) (if (number? b) b (car b)))
(cdr a))) (cdr a)))
(define kv car) (define kv car)
(define (mk-insert sort-to-left? sort=? right+ (define (mk-insert sort-to-left? sort=? right+
left-insert-adjust! left-insert-adjust!
left-rotate-adjust! right-rotate-adjust!) left-rotate-adjust! right-rotate-adjust!)
(define-values (rotate-left! rotate-right!) (define-values (rotate-left! rotate-right!)
(let ([mk (let ([mk
(lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!) (lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!)
(lambda (t) (lambda (t)
(let ([old-east (tree-east t)]) (let ([old-east (tree-east t)])
(let ([r (tree-west old-east)]) (let ([r (tree-west old-east)])
(set-tree-east! t r) (set-tree-east! t r)
(when r (when r
(set-tree-parent! r t))) (set-tree-parent! r t)))
(let ([p (tree-parent t)]) (let ([p (tree-parent t)])
(set-tree-parent! old-east p) (set-tree-parent! old-east p)
(if (eq? t (tree-left p)) (if (eq? t (tree-left p))
(set-tree-left! p old-east) (set-tree-left! p old-east)
(set-tree-right! p old-east))) (set-tree-right! p old-east)))
(set-tree-west! old-east t) (set-tree-west! old-east t)
(set-tree-parent! t old-east) (set-tree-parent! t old-east)
(adj-count! t old-east))))]) (adj-count! t old-east))))])
(values (mk tree-left tree-right set-tree-left! set-tree-right! (values (mk tree-left tree-right set-tree-left! set-tree-right!
left-rotate-adjust!) left-rotate-adjust!)
(mk tree-right tree-left set-tree-right! set-tree-left! (mk tree-right tree-left set-tree-right! set-tree-left!
right-rotate-adjust!)))) right-rotate-adjust!))))
(values (values
;; insert ;; insert
(lambda (pre-root n) (lambda (pre-root n)
(let ([new (let ([new
;; Insert: ;; Insert:
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n] [n n]
[parent pre-root] [parent pre-root]
[set-child! (lambda (t v) [set-child! (lambda (t v)
(set-tree-left! pre-root v))]) (set-tree-left! pre-root v))])
(cond (cond
[(not t) (let ([new (make-tree n #t 0 #f #f parent)]) [(not t) (let ([new (make-tree n #t 0 #f #f parent)])
(set-child! parent new) (set-child! parent new)
new)] new)]
[(sort=? n t) [(sort=? n t)
(set-tree-v! t n) (set-tree-v! t n)
pre-root] pre-root]
[(sort-to-left? n t) [(sort-to-left? n t)
(left-insert-adjust! t) (left-insert-adjust! t)
(loop (tree-left t) n t set-tree-left!)] (loop (tree-left t) n t set-tree-left!)]
[else [else
(loop (tree-right t) (right+ n t) t set-tree-right!)]))]) (loop (tree-right t) (right+ n t) t set-tree-right!)]))])
;; Restore red-black property: ;; Restore red-black property:
(let loop ([v new]) (let loop ([v new])
(let ([p (tree-parent v)]) (let ([p (tree-parent v)])
(when (and p (tree-red? p)) (when (and p (tree-red? p))
(let ([gp (tree-parent p)]) (let ([gp (tree-parent p)])
(let-values ([(tree-west tree-east rotate-west! rotate-east!) (let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? p (tree-left gp)) (if (eq? p (tree-left gp))
(values tree-left tree-right rotate-left! rotate-right!) (values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))]) (values tree-right tree-left rotate-right! rotate-left!))])
(let ([uncle (tree-east (tree-parent p))]) (let ([uncle (tree-east (tree-parent p))])
(if (and uncle (tree-red? uncle)) (if (and uncle (tree-red? uncle))
(begin (begin
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! uncle #f) (set-tree-red?! uncle #f)
(set-tree-red?! gp #t) (set-tree-red?! gp #t)
(loop gp)) (loop gp))
(let ([finish (lambda (v) (let ([finish (lambda (v)
(let* ([p (tree-parent v)] (let* ([p (tree-parent v)]
[gp (tree-parent p)]) [gp (tree-parent p)])
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! gp #t) (set-tree-red?! gp #t)
(rotate-east! gp) (rotate-east! gp)
(loop gp)))]) (loop gp)))])
(if (eq? v (tree-east p)) (if (eq? v (tree-east p))
(begin (begin
(rotate-west! p) (rotate-west! p)
(finish p)) (finish p))
(finish v)))))))))) (finish v))))))))))
(set-tree-red?! (tree-left pre-root) #f))) (set-tree-red?! (tree-left pre-root) #f)))
;; delete (fetch only) ;; delete (fetch only)
(lambda (pre-root n) (lambda (pre-root n)
(let ([orig-t (fetch-find-node pre-root n)]) (let ([orig-t (fetch-find-node pre-root n)])
(when orig-t (when orig-t
;; Delete note t if it has at most one child. ;; Delete note t if it has at most one child.
;; Otherwise, move a leaf's data to here, and ;; Otherwise, move a leaf's data to here, and
;; delete the leaf. ;; delete the leaf.
(let ([t (if (and (tree-left orig-t) (let ([t (if (and (tree-left orig-t)
(tree-right orig-t)) (tree-right orig-t))
(let loop ([t (tree-right orig-t)]) (let loop ([t (tree-right orig-t)])
(if (tree-left t) (if (tree-left t)
(loop (tree-left t)) (loop (tree-left t))
t)) t))
orig-t)]) orig-t)])
(unless (eq? t orig-t) (unless (eq? t orig-t)
;; Swap out: ;; Swap out:
(let ([delta (kv (tree-v t))]) (let ([delta (kv (tree-v t))])
(set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t))) (set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t)))
(let loop ([c (tree-right orig-t)]) (let loop ([c (tree-right orig-t)])
(when c (when c
(set-tree-v! c (k- (tree-v c) delta)) (set-tree-v! c (k- (tree-v c) delta))
(loop (tree-left c)))))) (loop (tree-left c))))))
;; Now we can delete t: ;; Now we can delete t:
(let ([child-t (or (tree-left t) (let ([child-t (or (tree-left t)
(tree-right t))] (tree-right t))]
[p (tree-parent t)]) [p (tree-parent t)])
(when child-t (when child-t
(set-tree-parent! child-t p) (set-tree-parent! child-t p)
;; Adjust relative index of left spine of the ;; Adjust relative index of left spine of the
;; right branch (in the case that there was only ;; right branch (in the case that there was only
;; a right branch) ;; a right branch)
(let loop ([c (tree-right t)]) (let loop ([c (tree-right t)])
(when c (when c
(set-tree-v! c (k+ (tree-v c) (tree-v t))) (set-tree-v! c (k+ (tree-v c) (tree-v t)))
(loop (tree-left c))))) (loop (tree-left c)))))
(if (eq? (tree-left p) t) (if (eq? (tree-left p) t)
(set-tree-left! p child-t) (set-tree-left! p child-t)
(set-tree-right! p child-t)) (set-tree-right! p child-t))
;; Restore red-black property: ;; Restore red-black property:
(when (not (tree-red? t)) (when (not (tree-red? t))
(let loop ([c child-t] [p p]) (let loop ([c child-t] [p p])
(cond (cond
[(and c (tree-red? c)) (set-tree-red?! c #f)] [(and c (tree-red? c)) (set-tree-red?! c #f)]
[(tree-parent p) [(tree-parent p)
(let-values ([(tree-west tree-east rotate-west! rotate-east!) (let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? c (tree-left p)) (if (eq? c (tree-left p))
(values tree-left tree-right rotate-left! rotate-right!) (values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))]) (values tree-right tree-left rotate-right! rotate-left!))])
(let ([sibling (tree-east p)]) (let ([sibling (tree-east p)])
(let ([z (if (tree-red? sibling) (let ([z (if (tree-red? sibling)
(begin (begin
(set-tree-red?! sibling #f) (set-tree-red?! sibling #f)
(set-tree-red?! p #t) (set-tree-red?! p #t)
(rotate-west! p) (rotate-west! p)
(tree-east p)) (tree-east p))
sibling)]) sibling)])
(if (not (or (and (tree-west z) (if (not (or (and (tree-west z)
(tree-red? (tree-west z))) (tree-red? (tree-west z)))
(and (tree-east z) (and (tree-east z)
(tree-red? (tree-east z))))) (tree-red? (tree-east z)))))
(begin (begin
(set-tree-red?! z #t) (set-tree-red?! z #t)
(loop p (tree-parent p))) (loop p (tree-parent p)))
(let ([w (if (not (and (tree-east z) (let ([w (if (not (and (tree-east z)
(tree-red? (tree-east z)))) (tree-red? (tree-east z))))
(begin (begin
(set-tree-red?! (tree-west z) #f) (set-tree-red?! (tree-west z) #f)
(set-tree-red?! z #t) (set-tree-red?! z #t)
(rotate-east! z) (rotate-east! z)
(tree-east p)) (tree-east p))
z)]) z)])
(set-tree-red?! w (tree-red? p)) (set-tree-red?! w (tree-red? p))
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! (tree-east w) #f) (set-tree-red?! (tree-east w) #f)
(rotate-west! p))))))])))))))))) (rotate-west! p))))))]))))))))))
(define-values (expunge-insert! ---) (define-values (expunge-insert! ---)
(mk-insert (mk-insert
;; sort-to-left? ;; sort-to-left?
(lambda (n t) (lambda (n t)
((+ n (tree-left-count t)) . < . (tree-v t))) ((+ n (tree-left-count t)) . < . (tree-v t)))
@ -207,14 +207,14 @@
(set-tree-left-count! t (add1 (tree-left-count t)))) (set-tree-left-count! t (add1 (tree-left-count t))))
;; left-rotate-adjust! ;; left-rotate-adjust!
(lambda (t old-right) (lambda (t old-right)
(set-tree-left-count! old-right (+ 1 (set-tree-left-count! old-right (+ 1
(tree-left-count old-right) (tree-left-count old-right)
(tree-left-count t)))) (tree-left-count t))))
;; right-rotate-adjust! ;; right-rotate-adjust!
(lambda (t old-left) (lambda (t old-left)
(set-tree-left-count! t (- (tree-left-count t) (set-tree-left-count! t (- (tree-left-count t)
(tree-left-count old-left) (tree-left-count old-left)
1))))) 1)))))
(define-values (fetch-insert! fetch-delete!) (define-values (fetch-insert! fetch-delete!)
(mk-insert (mk-insert
@ -232,28 +232,28 @@
;; left-rotate-adjust! ;; left-rotate-adjust!
(lambda (t old-right) (lambda (t old-right)
(set-tree-v! old-right (k+ (tree-v old-right) (set-tree-v! old-right (k+ (tree-v old-right)
(tree-v t)))) (tree-v t))))
;; right-rotate-adjust! ;; right-rotate-adjust!
(lambda (t old-left) (lambda (t old-left)
(set-tree-v! t (k- (tree-v t) (set-tree-v! t (k- (tree-v t)
(tree-v old-left)))))) (tree-v old-left))))))
(define (expunge-tree->list pre-root) (define (expunge-tree->list pre-root)
(let loop ([t (tree-left pre-root)]) (let loop ([t (tree-left pre-root)])
(if t (if t
(append (loop (tree-left t)) (append (loop (tree-left t))
(list (tree-v t)) (list (tree-v t))
(loop (tree-right t))) (loop (tree-right t)))
null))) null)))
(define (fetch-find-node pre-root n) (define (fetch-find-node pre-root n)
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n]) [n n])
(and t (and t
(cond (cond
[(= n (kv (tree-v t))) t] [(= n (kv (tree-v t))) t]
[(< n (kv (tree-v t))) (loop (tree-left t) n)] [(< n (kv (tree-v t))) (loop (tree-left t) n)]
[else (loop (tree-right t) (- n (kv (tree-v t))))])))) [else (loop (tree-right t) (- n (kv (tree-v t))))]))))
(define (fetch-find pre-root n) (define (fetch-find pre-root n)
(let ([t (fetch-find-node pre-root n)]) (let ([t (fetch-find-node pre-root n)])
@ -262,22 +262,22 @@
(define (fetch-shift! pre-root n) (define (fetch-shift! pre-root n)
(fetch-delete! pre-root n) (fetch-delete! pre-root n)
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n]) [n n])
(when t (when t
(if (n . < . (kv (tree-v t))) (if (n . < . (kv (tree-v t)))
(begin (begin
(set-tree-v! t (k- (tree-v t) 1)) (set-tree-v! t (k- (tree-v t) 1))
(loop (tree-left t) n)) (loop (tree-left t) n))
(loop (tree-right t) (loop (tree-right t)
(- n (kv (tree-v t)))))))) (- n (kv (tree-v t))))))))
(define (fetch-tree->list pre-root) (define (fetch-tree->list pre-root)
(let loop ([t (tree-left pre-root)][d 0]) (let loop ([t (tree-left pre-root)][d 0])
(if t (if t
(append (loop (tree-left t) d) (append (loop (tree-left t) d)
(list (k+ (tree-v t) d)) (list (k+ (tree-v t) d))
(loop (tree-right t) (+ d (kv (tree-v t))))) (loop (tree-right t) (+ d (kv (tree-v t)))))
null)))) null))))
#| #|
@ -321,7 +321,7 @@ Tests:
[(< n 0) (fetch-delete! t (- n))] [(< n 0) (fetch-delete! t (- n))]
[(inexact? n) (fetch-shift! t (inexact->exact n))] [(inexact? n) (fetch-shift! t (inexact->exact n))]
[else (fetch-insert! t (list n))]) [else (fetch-insert! t (list n))])
(printf "Check ~a~n" v) (printf "Check ~a\n" v)
(let ([v (map list v)]) (let ([v (map list v)])
(unless (equal? (fetch-tree->list t) v) (unless (equal? (fetch-tree->list t) v)
(error 'bad "~s != ~s" (fetch-tree->list t) v)))) (error 'bad "~s != ~s" (fetch-tree->list t) v))))
@ -356,32 +356,32 @@ Tests:
(cons (cons
(cons n l) (cons n l)
(map (lambda (r) (cons (car l) r)) (map (lambda (r) (cons (car l) r))
(in-all-positions n (cdr l)))))) (in-all-positions n (cdr l))))))
(define (permutations l) (define (permutations l)
(if (or (null? l) (if (or (null? l)
(null? (cdr l))) (null? (cdr l)))
(list l) (list l)
(apply (apply
append append
(map (lambda (lol) (map (lambda (lol)
(in-all-positions (car l) lol)) (in-all-positions (car l) lol))
(permutations (cdr l)))))) (permutations (cdr l))))))
(define perms (permutations '(1 2 3 4 5 6 7 8))) (define perms (permutations '(1 2 3 4 5 6 7 8)))
(for-each (lambda (l) (for-each (lambda (l)
(let ([t (new-tree)]) (let ([t (new-tree)])
(for-each (lambda (i) (for-each (lambda (i)
(fetch-insert! t (list i))) (fetch-insert! t (list i)))
l) l)
(unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8))) (unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8)))
(error 'perms "bad: ~a" l)) (error 'perms "bad: ~a" l))
(for-each (lambda (i) (for-each (lambda (i)
(fetch-delete! t i)) (fetch-delete! t i))
l) l)
(unless (equal? (fetch-tree->list t) '()) (unless (equal? (fetch-tree->list t) '())
(error 'perms "remove bad: ~a" l)))) (error 'perms "remove bad: ~a" l))))
perms) perms)
|# |#

10
collects/net/qp.ss
View File

@ -1,8 +1,8 @@
;;; ;;;
;;; <qp.ss> ---- Quoted Printable Encoding/Decoding ;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
;;; ;;;
;;; Copyright (C) 2002 by PLT. ;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona. ;;; Copyright (C) 2001 by Francisco Solsona.
;;; ;;;
;;; This file is part of mime-plt. ;;; This file is part of mime-plt.
@ -26,12 +26,10 @@
;; Commentary: ;; Commentary:
(module qp mzscheme (module qp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
"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

4
collects/net/sendmail.ss
View File

@ -1,7 +1,5 @@
(module sendmail mzscheme (module sendmail mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "sendmail-sig.ss" "sendmail-unit.ss")
"sendmail-sig.ss"
"sendmail-unit.ss")
(define-values/invoke-unit/infer sendmail@) (define-values/invoke-unit/infer sendmail@)

172
collects/net/sendurl.ss
View File

@ -4,9 +4,9 @@
(lib "etc.ss") (lib "etc.ss")
(lib "port.ss") (lib "port.ss")
(lib "sendevent.ss")) (lib "sendevent.ss"))
(provide send-url unix-browser-list browser-preference? external-browser) (provide send-url unix-browser-list browser-preference? external-browser)
(define separate-by-default? (define separate-by-default?
(get-preference 'new-browser-for-urls (lambda () #t))) (get-preference 'new-browser-for-urls (lambda () #t)))
@ -22,122 +22,122 @@
(if (browser-preference? x) (if (browser-preference? x)
x x
(error 'external-browser "~a is not a valid browser preference" x))))) (error 'external-browser "~a is not a valid browser preference" x)))))
; send-url : str [bool] -> void ; send-url : str [bool] -> void
(define send-url (define send-url
(opt-lambda (url-str [separate-window? separate-by-default?]) (opt-lambda (url-str [separate-window? separate-by-default?])
(cond (cond
[(procedure? (external-browser)) [(procedure? (external-browser))
((external-browser) url-str)] ((external-browser) url-str)]
[(eq? (system-type) 'macos) [(eq? (system-type) 'macos)
(if (regexp-match "Blue Box" (system-type 'machine)) (if (regexp-match "Blue Box" (system-type 'machine))
;; Classic inside OS X: ;; Classic inside OS X:
(let loop ([l '("MSIE" "NAVG")]) (let loop ([l '("MSIE" "NAVG")])
(if (null? l) (if (null? l)
(error 'send-url "couldn't start Internet Explorer or Netscape") (error 'send-url "couldn't start Internet Explorer or Netscape")
(with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))]) (with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
(subprocess #f #f #f "by-id" (car l)) (subprocess #f #f #f "by-id" (car l))
(let loop ([retries 2]) ;; <<< Yuck <<< (let loop ([retries 2]) ;; <<< Yuck <<<
(if (zero? retries) (if (zero? retries)
(error "enough already") ; caught above (error "enough already") ; caught above
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(loop (sub1 retries)))]) (loop (sub1 retries)))])
(let ([t (thread (lambda () (let ([t (thread (lambda ()
(send-event (car l) "GURL" "GURL" url-str)))]) (send-event (car l) "GURL" "GURL" url-str)))])
(sync/timeout 1 t) ;; <<< Yuck (timeout) <<< (sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
(when (thread-running? t) (when (thread-running? t)
(kill-thread t) (kill-thread t)
(error "timeout"))))))))) (error "timeout")))))))))
;; Normal OS Classic: ;; Normal OS Classic:
(send-event "MACS" "GURL" "GURL" url-str))] (send-event "MACS" "GURL" "GURL" url-str))]
[(or (eq? (system-type) 'macosx) [(or (eq? (system-type) 'macosx)
(equal? "ppc-darwin" (system-library-subpath))) (equal? "ppc-darwin" (system-library-subpath)))
;; not sure what changed, but this is wrong now.... -robby ;; not sure what changed, but this is wrong now.... -robby
;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25"))) ;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))] (browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
[(eq? (system-type) 'windows) [(eq? (system-type) 'windows)
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)] (shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
[(eq? (system-type) 'unix) [(eq? (system-type) 'unix)
(let ([preferred (or (external-browser) (get-preference 'external-browser))]) (let ([preferred (or (external-browser) (get-preference 'external-browser))])
(cond (cond
[(use-browser 'opera preferred) [(use-browser 'opera preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
;; opera may not return -- always open asyncronously ;; opera may not return -- always open asyncronously
;; opera starts a new browser automatically, if it can't find one ;; opera starts a new browser automatically, if it can't find one
(browser-process* browser-path "-remote" (browser-process* browser-path "-remote"
(format "openURL(~a)" (format "openURL(~a)"
(if separate-window? (if separate-window?
(format "~a,new-window" url-str) (format "~a,new-window" url-str)
url-str))))] url-str))))]
[(use-browser 'galeon preferred) [(use-browser 'galeon preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
(browser-process* browser-path (browser-process* browser-path
(if separate-window? "-w" "-x") (if separate-window? "-w" "-x")
url-str))] url-str))]
[(or (use-browser 'netscape preferred) [(or (use-browser 'netscape preferred)
(use-browser 'mozilla preferred)) (use-browser 'mozilla preferred))
=> =>
(lambda (browser-path) (lambda (browser-path)
;; netscape's -remote returns with an error code, if no ;; netscape's -remote returns with an error code, if no
;; netscape is around. start a new netscape in that case. ;; netscape is around. start a new netscape in that case.
(or (system* browser-path "-remote" (or (system* browser-path "-remote"
(format "openURL(~a)" (format "openURL(~a)"
(if separate-window? (if separate-window?
(format "~a,new-window" url-str) (format "~a,new-window" url-str)
url-str))) url-str)))
(browser-process* browser-path url-str)))] (browser-process* browser-path url-str)))]
[(use-browser 'dillo preferred) [(use-browser 'dillo preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
(browser-process* browser-path url-str))] (browser-process* browser-path url-str))]
[(custom-browser? preferred) [(custom-browser? preferred)
(let ([cmd (string-append (car preferred) (let ([cmd (string-append (car preferred)
url-str url-str
(cdr preferred))]) (cdr preferred))])
(browser-process cmd))] (browser-process cmd))]
[else [else
(error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))] (error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
[else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))]))) [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
; : tst -> bool ; : tst -> bool
(define (custom-browser? x) (define (custom-browser? x)
(and (pair? x) (string? (car x)) (string? (cdr x)))) (and (pair? x) (string? (car x)) (string? (cdr x))))
(define unix-browser-list '(opera galeon netscape mozilla dillo)) (define unix-browser-list '(opera galeon netscape mozilla dillo))
; : (cons tst (listof tst)) -> str ; : (cons tst (listof tst)) -> str
(define (orify l) (define (orify l)
(cond (cond
[(null? (cdr l)) (format "~a" (car l))] [(null? (cdr l)) (format "~a" (car l))]
[(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))] [(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))]
[else [else
(let loop ([l l]) (let loop ([l l])
(cond (cond
[(null? (cdr l)) (format "or ~a" (car l))] [(null? (cdr l)) (format "or ~a" (car l))]
[else (string-append (format "~a, " (car l)) (loop (cdr l)))]))])) [else (string-append (format "~a, " (car l)) (loop (cdr l)))]))]))
; : sym sym -> (U #f str) ; : sym sym -> (U #f str)
; to find the path for the named browser, unless another browser is preferred ; to find the path for the named browser, unless another browser is preferred
(define (use-browser browser-name preferred) (define (use-browser browser-name preferred)
(and (or (not preferred) (and (or (not preferred)
(eq? preferred browser-name)) (eq? preferred browser-name))
(find-executable-path (symbol->string browser-name) #f))) (find-executable-path (symbol->string browser-name) #f)))
;; run-browser : process-proc list-of-strings -> void ;; run-browser : process-proc list-of-strings -> void
(define (run-browser process*/ports args) (define (run-browser process*/ports args)
(let-values ([(stdout stdin pid stderr control) (let-values ([(stdout stdin pid stderr control)
(apply values (apply process*/ports (apply values (apply process*/ports
(open-output-nowhere) (open-output-nowhere)
#f #f
(current-error-port) (current-error-port)
args))]) args))])
(close-output-port stdin) (close-output-port stdin)
(thread (lambda () (thread (lambda ()
(control 'wait) (control 'wait)
(when (eq? 'done-error (control 'status)) (when (eq? 'done-error (control 'status))
(error 'run-browser "process execute failed: ~e" args)))) (error 'run-browser "process execute failed: ~e" args))))
(void))) (void)))
(define (browser-process* . args) (define (browser-process* . args)

4
collects/net/smtp.ss
View File

@ -1,7 +1,5 @@
(module smtp mzscheme (module smtp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "smtp-sig.ss" "smtp-unit.ss")
"smtp-sig.ss"
"smtp-unit.ss")
(define-values/invoke-unit/infer smtp@) (define-values/invoke-unit/infer smtp@)

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

@ -2,62 +2,62 @@
(provide make-ssl-tcp@) (provide make-ssl-tcp@)
(require (lib "unit.ss") (require (lib "unit.ss")
"tcp-sig.ss" "tcp-sig.ss"
(lib "mzssl.ss" "openssl") (lib "mzssl.ss" "openssl")
(lib "etc.ss")) (lib "etc.ss"))
(define (make-ssl-tcp@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
client-cert-file client-key-file client-root-cert-files)
(unit
(import)
(export tcp^)
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
(define (tcp-abandon-port p) (define (make-ssl-tcp@
(if (input-port? p) server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
(close-input-port p) client-cert-file client-key-file client-root-cert-files)
(close-output-port p))) (unit
(import)
(export tcp^)
(define tcp-accept ssl-accept) (define ctx (ssl-make-client-context))
(define tcp-accept/enable-break ssl-accept/enable-break) (when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
;; accept-ready? doesn't really work for SSL: (define (tcp-abandon-port p)
(define (tcp-accept-ready? p) (if (input-port? p)
#f) (close-input-port p)
(close-output-port p)))
(define tcp-addresses ssl-addresses) (define tcp-accept ssl-accept)
(define tcp-close ssl-close) (define tcp-accept/enable-break ssl-accept/enable-break)
(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-listen ;; accept-ready? doesn't really work for SSL:
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f]) (define (tcp-accept-ready? p)
(let ([l (ssl-listen port allow-k reuse? hostname)]) #f)
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
(define tcp-listener? ssl-listener?)))) (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-listen
(opt-lambda (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))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
(define tcp-listener? ssl-listener?))))

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

@ -1,14 +1,14 @@
(module tcp-redirect mzscheme (module tcp-redirect mzscheme
(provide tcp-redirect) (provide tcp-redirect)
(require (lib "unit.ss") (require (lib "unit.ss")
(lib "async-channel.ss") (lib "async-channel.ss")
(lib "etc.ss") (lib "etc.ss")
"tcp-sig.ss") "tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept) (define raw:tcp-accept tcp-accept)
(define raw:tcp-accept/enable-break tcp-accept/enable-break) (define raw:tcp-accept/enable-break tcp-accept/enable-break)
(define raw:tcp-accept-ready? tcp-accept-ready?) (define raw:tcp-accept-ready? tcp-accept-ready?)
(define raw:tcp-addresses tcp-addresses) (define raw:tcp-addresses tcp-addresses)
(define raw:tcp-close tcp-close) (define raw:tcp-close tcp-close)
@ -16,11 +16,11 @@
(define raw:tcp-connect/enable-break tcp-connect/enable-break) (define raw:tcp-connect/enable-break tcp-connect/enable-break)
(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
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"]) (opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
@ -29,12 +29,12 @@
(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
@ -42,7 +42,7 @@
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))]) (let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(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
@ -56,20 +56,20 @@
#;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))]) #;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(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)
@ -77,7 +77,7 @@
(hash-table-remove! (hash-table-remove!
port-table port-table
(pipe-listener-port tcp-listener)))) (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)
@ -99,13 +99,13 @@
(cons to-in to-out)) (cons to-in to-out))
(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
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f]) (opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
@ -118,22 +118,22 @@
(hash-table-put! port-table port listener) (hash-table-put! 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-table nat[port] -> tcp-listener)
(define port-table (make-hash-table)) (define port-table (make-hash-table))
(define redirect-table (define redirect-table
(let ([table (make-hash-table)]) (let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t)) (for-each (lambda (x) (hash-table-put! 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-table-get redirect-table port (lambda () #f)))))))

20
collects/net/tcp-sig.ss
View File

@ -1,11 +1,11 @@
(module tcp-sig (lib "a-signature.ss") (module tcp-sig (lib "a-signature.ss")
tcp-abandon-port tcp-abandon-port
tcp-accept tcp-accept
tcp-accept/enable-break tcp-accept/enable-break
tcp-accept-ready? tcp-accept-ready?
tcp-addresses tcp-addresses
tcp-close tcp-close
tcp-connect tcp-connect
tcp-connect/enable-break tcp-connect/enable-break
tcp-listen tcp-listen
tcp-listener?) tcp-listener?)

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

@ -1,7 +1,6 @@
(module tcp-unit mzscheme (module tcp-unit mzscheme
(provide tcp@) (provide tcp@)
(require (lib "unit.ss") (require (lib "unit.ss") "tcp-sig.ss")
"tcp-sig.ss")
(define-unit-from-context tcp@ tcp^)) (define-unit-from-context tcp@ tcp^))

157
collects/net/unihead.ss
View File

@ -1,53 +1,53 @@
(module unihead mzscheme (module unihead mzscheme
(require (lib "base64.ss" "net") (require (lib "base64.ss" "net")
(lib "qp.ss" "net") (lib "qp.ss" "net")
(lib "string.ss")) (lib "string.ss"))
(provide encode-for-header (provide encode-for-header
decode-for-header decode-for-header
generalize-encoding) generalize-encoding)
(define re:ascii #rx"^[\u0-\u7F]*$") (define re:ascii #rx"^[\u0-\u7F]*$")
(define (encode-for-header s) (define (encode-for-header s)
(if (regexp-match? re:ascii s) (if (regexp-match? re:ascii s)
s s
(let ([l (regexp-split #rx"\r\n" s)]) (let ([l (regexp-split #rx"\r\n" s)])
(apply string-append (apply string-append
(map encode-line-for-header l))))) (map encode-line-for-header l)))))
(define (encode-line-for-header s) (define (encode-line-for-header s)
(define (loop s string->bytes charset encode encoding) (define (loop s string->bytes charset encode encoding)
;; Find ASCII (and no "=") prefix before a space ;; Find ASCII (and no "=") prefix before a space
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)]) (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
(if m (if m
(string-append (string-append
(cadr m) (cadr m)
(loop (caddr m) string->bytes charset encode encoding)) (loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space ;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)]) (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m (if m
(string-append (string-append
(loop (cadr m) string->bytes charset encode encoding) (loop (cadr m) string->bytes charset encode encoding)
(caddr m)) (caddr m))
(format "=?~a?~a?~a?=" (format "=?~a?~a?~a?="
charset encoding charset encoding
(regexp-replace* #rx#"[\r\n]+$" (regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s)) (encode (string->bytes s))
#""))))))) #"")))))))
(cond (cond
[(regexp-match? re:ascii s) [(regexp-match? re:ascii s)
;; ASCII - do nothing ;; ASCII - do nothing
s] s]
[(regexp-match? #rx"[^\u0-\uFF]" s) [(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8 ;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")] (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else [else
;; use Latin-1 ;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1" (loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s) (lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_")) (regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")])) "Q")]))
;; ---------------------------------------- ;; ----------------------------------------
@ -73,45 +73,46 @@
(define (decode-for-header s) (define (decode-for-header s)
(and s (and s
(let ([m (regexp-match re:encoded (let ([m (regexp-match re:encoded
(string->bytes/latin-1 s (char->integer #\?)))]) (string->bytes/latin-1 s (char->integer #\?)))])
(if m (if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q")) (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling ;; quoted-printable, with special _ handling
(lambda (x) (lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" "))) (qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64: ;; base64:
base64-decode) base64-decode)
(cadddr (cdr m)))] (cadddr (cdr m)))]
[encoding (caddr m)]) [encoding (caddr m)])
(string-append (string-append
(decode-for-header (bytes->string/latin-1 (cadr m))) (decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)]) (let ([encoding (generalize-encoding encoding)])
(cond (cond
[(regexp-match? re:utf-8 encoding) [(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)] (bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter [else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding) "UTF-8")]) (bytes->string/latin-1 encoding)
(if c "UTF-8")])
(let-values ([(r got status) (if c
(bytes-convert c s)]) (let-values ([(r got status)
(bytes-close-converter c) (bytes-convert c s)])
(if (eq? status 'complete) (bytes-close-converter c)
(bytes->string/utf-8 r #\?) (if (eq? status 'complete)
(bytes->string/latin-1 s))) (bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))])) (bytes->string/latin-1 s)))
(let ([rest (cadddr (cddr m))]) (bytes->string/latin-1 s)))]))
(let ([rest (let ([rest (cadddr (cddr m))])
;; A CR-LF-space-encoding sequence means that we (let ([rest
;; should drop the space. ;; A CR-LF-space-encoding sequence means that we
(if (and (> (bytes-length rest) 4) ;; should drop the space.
(= 13 (bytes-ref rest 0)) (if (and (> (bytes-length rest) 4)
(= 10 (bytes-ref rest 1)) (= 13 (bytes-ref rest 0))
(= 32 (bytes-ref rest 2)) (= 10 (bytes-ref rest 1))
(let ([m (regexp-match-positions (= 32 (bytes-ref rest 2))
re:encoded rest)]) (let ([m (regexp-match-positions
(and m (= (caaddr m) 5)))) re:encoded rest)])
(subbytes rest 3) (and m (= (caaddr m) 5))))
rest)]) (subbytes rest 3)
(decode-for-header (bytes->string/latin-1 rest)))))) rest)])
s))))) (decode-for-header (bytes->string/latin-1 rest))))))
s)))))