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

reformatting

Browse Source 
svn: r9853

original commit: 0d41afdb6d
This commit is contained in:
Eli Barzilay 2008-05-15 16:55:15 +00:00
parent 8083829c5e
commit a9acd2b5a3
16 changed files with 467 additions and 480 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/net/cgi.ss
View File

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

8
collects/net/cookie.ss
View File

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

8
collects/net/dns.ss
View File

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

8
collects/net/ftp.ss
View File

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

81
collects/net/imap.ss
View File

@ -1,49 +1,50 @@
(module imap mzscheme #lang scheme/base
(require mzlib/unit mzlib/contract "imap-sig.ss" "imap-unit.ss") (require scheme/unit scheme/contract "imap-sig.ss" "imap-unit.ss")
(define-values/invoke-unit/infer imap@) (define-values/invoke-unit/infer imap@)
(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
(case-> (case->
(imap-connection? (or/c false/c bytes?) . -> . (listof (list/c (listof symbol?) bytes?))) (imap-connection? (or/c false/c bytes?)
(imap-connection? (or/c false/c bytes?) (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?))))]) . -> .
(listof (list/c (listof symbol?) bytes?))))])
(provide (provide
imap-connection? imap-connection?
imap-connect imap-connect* imap-connect imap-connect*
imap-disconnect imap-disconnect
imap-force-disconnect imap-force-disconnect
imap-reselect imap-reselect
imap-examine imap-examine
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?
imap-messages imap-messages
imap-recent imap-recent
imap-uidnext imap-uidnext
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)

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

@ -26,116 +26,111 @@
;; ;;
;; Commentary: ;; Commentary:
(module mime-util mzscheme #lang scheme/base
(require mzlib/etc)
(provide string-tokenizer (provide string-tokenizer
trim-all-spaces trim-all-spaces
trim-spaces trim-spaces
trim-comments trim-comments
lowercase lowercase
warning warning
cat) cat)
;; string-index returns the leftmost index in string s ;; string-index returns the leftmost index in string s
;; that has character c ;; that has character c
(define (string-index s c) (define (string-index 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 c s) (define (string-tokenizer 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 "\""))
(define re:space (regexp "[ \t\n\r\v]")) (define re:space (regexp "[ \t\n\r\v]"))
(define (trim-all-spaces str) (define (trim-all-spaces str)
;; 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 str) (define (trim-spaces str)
(trim-right (trim-left str))) (trim-right (trim-left str)))
(define re:left-spaces (regexp "^[ \t\r\n\v]+")) (define re:left-spaces (regexp "^[ \t\r\n\v]+"))
(define (trim-left str) (define (trim-left str)
(regexp-replace re:left-spaces str "")) (regexp-replace re:left-spaces str ""))
(define re:right-spaces (regexp "[ \t\r\n\v]+$")) (define re:right-spaces (regexp "[ \t\r\n\v]+$"))
(define (trim-right str) (define (trim-right str)
(regexp-replace re:right-spaces str "")) (regexp-replace re:right-spaces str ""))
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")) (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define (trim-comments str) (define (trim-comments 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 str) (define (lowercase 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
#;
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(newline (current-error-port)))
)
;; 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)))
(let loop ([ln (read-line in)])
(unless (eof-object? ln)
(fprintf out "~a\n" ln)
(loop (read-line in))))))
(define warning
void
#;
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(newline (current-error-port)))
) )
;; Copies its input `in' to its ouput port if given, it uses
;; current-output-port if out is not provided.
(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)))))
;;; mime-util.ss ends here ;;; mime-util.ss ends here

34
collects/net/mime.ss
View File

@ -26,26 +26,26 @@
;; ;;
;; Commentary: ;; Commentary:
(module mime mzscheme #lang scheme/base
(require mzlib/unit (require scheme/unit
"mime-sig.ss" "mime-sig.ss"
"mime-unit.ss" "mime-unit.ss"
"qp-sig.ss" "qp-sig.ss"
"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^)
(define-unit-from-context head@ head^) (define-unit-from-context head@ head^)
(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

8
collects/net/nntp.ss
View File

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

8
collects/net/pop3.ss
View File

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

8
collects/net/qp.ss
View File

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

8
collects/net/sendmail.ss
View File

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

8
collects/net/smtp.ss
View File

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

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

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

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

@ -1,138 +1,133 @@
(module tcp-redirect mzscheme #lang scheme/base
(provide tcp-redirect) (provide tcp-redirect)
(require mzlib/unit (require scheme/unit
mzlib/async-channel scheme/tcp
mzlib/etc scheme/async-channel
"tcp-sig.ss") "tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-abandon-port tcp-abandon-port)
(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)
(define raw:tcp-connect tcp-connect) (define raw:tcp-connect tcp-connect)
(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 redirected-ports [redirected-address "127.0.0.1"])
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"]) (unit
(unit (import)
(import) (export tcp^)
(export tcp^) ;; : (make-pipe-listener nat (channel (cons iport oport)))
; : (make-pipe-listener nat (channel (cons iport oport))) (define-struct pipe-listener (port channel))
(define-struct pipe-listener (port channel))
; : port -> void ;; : port -> void
(define (tcp-abandon-port tcp-port) (define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port) (when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port))) (raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport ;; : listener -> iport oport
(define (tcp-accept tcp-listener) (define (tcp-accept tcp-listener)
(cond (cond
[(pipe-listener? tcp-listener) [(pipe-listener? tcp-listener)
(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
[(pipe-listener? tcp-listener) [(pipe-listener? tcp-listener)
; XXX put this into async-channel.ss as async-channel-get/enable-break ;; XXX put this into async-channel.ss as async-channel-get/enable-break
(sync/enable-break (sync/enable-break
(handle-evt (handle-evt
(pipe-listener-channel tcp-listener) (pipe-listener-channel tcp-listener)
(lambda (in-out) (lambda (in-out)
(values (car in-out) (cdr in-out)))))] (values (car in-out) (cdr in-out)))))]
#;(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)
(raw:tcp-close tcp-listener) (raw:tcp-close tcp-listener)
(hash-table-remove! (hash-remove! port-table (pipe-listener-port tcp-listener))))
port-table
(pipe-listener-port tcp-listener))))
; : (str nat -> iport oport) -> str nat -> iport oport ;; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw) (define (gen-tcp-connect raw)
(lambda (hostname-string port) (lambda (hostname-string port)
(if (and (string=? redirected-address hostname-string) (if (and (string=? redirected-address hostname-string)
(redirect? port)) (redirect? port))
(let-values ([(to-in from-out) (make-pipe)] (let-values ([(to-in from-out) (make-pipe)]
[(from-in to-out) (make-pipe)]) [(from-in to-out) (make-pipe)])
(async-channel-put (async-channel-put
(pipe-listener-channel (pipe-listener-channel
(hash-table-get (hash-ref port-table port
port-table (lambda ()
port (raise (make-exn:fail:network
(lambda () (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
(raise (make-exn:fail:network hostname-string port)
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)" (current-continuation-marks))))))
hostname-string port) (cons to-in to-out))
(current-continuation-marks)))))) (values from-in from-out))
(cons to-in to-out)) (raw hostname-string port))))
(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)) (define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport ;; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break)) (define tcp-connect/enable-break
(gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag. ;; FIX - support the reuse? flag.
(define tcp-listen (define (tcp-listen port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f]) (hash-ref port-table port
(hash-table-get (lambda ()
port-table (if (redirect? port)
port (let ([listener (make-pipe-listener port (make-async-channel))])
(lambda () (hash-set! port-table port listener)
(if (redirect? port) listener)
(let ([listener (make-pipe-listener port (make-async-channel))]) (raw:tcp-listen port max-allow-wait reuse? hostname-string)))))
(hash-table-put! port-table port listener)
listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
; : tst -> bool ;; : tst -> bool
(define (tcp-listener? x) (define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x))) (or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ---------- ;; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener) ;; : (hash nat[port] -> tcp-listener)
(define port-table (make-hash-table)) (define port-table (make-hasheq))
(define redirect-table (define redirect-table
(let ([table (make-hash-table)]) (let ([table (make-hasheq)])
(for-each (lambda (x) (hash-table-put! table x #t)) (for-each (lambda (x) (hash-set! table x #t))
redirected-ports) redirected-ports)
table)) table))
; : nat -> bool ;; : nat -> bool
(define (redirect? port) (define (redirect? port)
(hash-table-get redirect-table port (lambda () #f))))))) (hash-ref redirect-table port #f))
))

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

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

218
collects/net/unihead.ss
View File

@ -1,118 +1,118 @@
(module unihead mzscheme #lang mzscheme
(require net/base64 (require net/base64
net/qp net/qp
mzlib/string) mzlib/string)
(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")]))
;; ---------------------------------------- ;; ----------------------------------------
(define re:us-ascii #rx#"^(?i:us-ascii)$") (define re:us-ascii #rx#"^(?i:us-ascii)$")
(define re:iso #rx#"^(?i:iso-8859-1)$") (define re:iso #rx#"^(?i:iso-8859-1)$")
(define re:gb #rx#"^(?i:gb(?:2312)?)$") (define re:gb #rx#"^(?i:gb(?:2312)?)$")
(define re:ks_c #rx#"^(?i:ks_c_5601-1987)$") (define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
(define re:utf-8 #rx#"^(?i:utf-8)$") (define re:utf-8 #rx#"^(?i:utf-8)$")
(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$") (define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
(define (generalize-encoding encoding) (define (generalize-encoding encoding)
;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312 ;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
;; as GBK, because some mailers are broken. ;; as GBK, because some mailers are broken.
(cond [(or (regexp-match? re:iso encoding) (cond [(or (regexp-match? re:iso encoding)
(regexp-match? re:us-ascii encoding)) (regexp-match? re:us-ascii encoding))
(if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")] (if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
[(regexp-match? re:gb encoding) [(regexp-match? re:gb encoding)
(if (bytes? encoding) #"GBK" "GBK")] (if (bytes? encoding) #"GBK" "GBK")]
[(regexp-match? re:ks_c encoding) [(regexp-match? re:ks_c encoding)
(if (bytes? encoding) #"CP949" "CP949")] (if (bytes? encoding) #"CP949" "CP949")]
[else encoding])) [else encoding]))
(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) (bytes->string/latin-1 encoding)
"UTF-8")]) "UTF-8")])
(if c (if c
(let-values ([(r got status) (let-values ([(r got status)
(bytes-convert c s)]) (bytes-convert c s)])
(bytes-close-converter c) (bytes-close-converter c)
(if (eq? status 'complete) (if (eq? status 'complete)
(bytes->string/utf-8 r #\?) (bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s))) (bytes->string/latin-1 s)))
(bytes->string/latin-1 s)))])) (bytes->string/latin-1 s)))]))
(let ([rest (cadddr (cddr m))]) (let ([rest (cadddr (cddr m))])
(let ([rest (let ([rest
;; A CR-LF-space-encoding sequence means that we ;; A CR-LF-space-encoding sequence means that we
;; should drop the space. ;; should drop the space.
(if (and (> (bytes-length rest) 4) (if (and (> (bytes-length rest) 4)
(= 13 (bytes-ref rest 0)) (= 13 (bytes-ref rest 0))
(= 10 (bytes-ref rest 1)) (= 10 (bytes-ref rest 1))
(= 32 (bytes-ref rest 2)) (= 32 (bytes-ref rest 2))
(let ([m (regexp-match-positions (let ([m (regexp-match-positions
re:encoded rest)]) re:encoded rest)])
(and m (= (caaddr m) 5)))) (and m (= (caaddr m) 5))))
(subbytes rest 3) (subbytes rest 3)
rest)]) rest)])
(decode-for-header (bytes->string/latin-1 rest)))))) (decode-for-header (bytes->string/latin-1 rest))))))
s))))) s))))