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
(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@)
(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
(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^)
(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
(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@)
(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
(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@)
(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
(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@)
(define-values/invoke-unit/infer imap@)
(provide/contract
[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?) (or/c false/c bytes?)
. -> .
(listof (list/c (listof symbol?) bytes?))))])
(provide/contract
[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?) (or/c false/c bytes?)
. -> .
(listof (list/c (listof symbol?) bytes?))))])
(provide
imap-connection?
imap-connect imap-connect*
imap-disconnect
imap-force-disconnect
imap-reselect
imap-examine
imap-noop
imap-poll
imap-status
(provide
imap-connection?
imap-connect imap-connect*
imap-disconnect
imap-force-disconnect
imap-reselect
imap-examine
imap-noop
imap-poll
imap-status
imap-port-number ; a parameter
imap-port-number ; a parameter
imap-new?
imap-messages
imap-recent
imap-uidnext
imap-uidvalidity
imap-unseen
imap-reset-new!
imap-new?
imap-messages
imap-recent
imap-uidnext
imap-uidvalidity
imap-unseen
imap-reset-new!
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-mailbox-exists?
imap-create-mailbox
imap-mailbox-exists?
imap-create-mailbox
imap-mailbox-flags))
imap-mailbox-flags)

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

@ -26,116 +26,111 @@
;;
;; Commentary:
(module mime-util mzscheme
(require mzlib/etc)
#lang scheme/base
(provide string-tokenizer
trim-all-spaces
trim-spaces
trim-comments
lowercase
warning
cat)
(provide string-tokenizer
trim-all-spaces
trim-spaces
trim-comments
lowercase
warning
cat)
;; string-index returns the leftmost index in string s
;; that has character c
(define (string-index s c)
(let ([n (string-length s)])
(let loop ([i 0])
(cond [(>= i n) #f]
[(char=? (string-ref s i) c) i]
[else (loop (+ i 1))]))))
;; string-index returns the leftmost index in string s
;; that has character c
(define (string-index s c)
(let ([n (string-length s)])
(let loop ([i 0])
(cond [(>= i n) #f]
[(char=? (string-ref s i) c) i]
[else (loop (+ i 1))]))))
;; string-tokenizer breaks string s into substrings separated by character c
(define (string-tokenizer c s)
(let loop ([s s])
(if (string=? s "") '()
(let ([i (string-index s c)])
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
(list s))))))
;; string-tokenizer breaks string s into substrings separated by character c
(define (string-tokenizer c s)
(let loop ([s s])
(if (string=? s "") '()
(let ([i (string-index s c)])
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1) (string-length s))))
(list s))))))
;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\""))
(define re:space (regexp "[ \t\n\r\v]"))
(define (trim-all-spaces str)
;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted.
(let-values ([(unquoted quoted)
(let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse (cons str unquoted)) (reverse quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))
;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\""))
(define re:space (regexp "[ \t\n\r\v]"))
(define (trim-all-spaces str)
;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted.
(let-values ([(unquoted quoted)
(let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse (cons str unquoted)) (reverse quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))
;; Only trims left and right spaces:
(define (trim-spaces str)
(trim-right (trim-left str)))
;; Only trims left and right spaces:
(define (trim-spaces str)
(trim-right (trim-left str)))
(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
(define (trim-left str)
(regexp-replace re:left-spaces str ""))
(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
(define (trim-left str)
(regexp-replace re:left-spaces str ""))
(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
(define (trim-right str)
(regexp-replace re:right-spaces str ""))
(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
(define (trim-right str)
(regexp-replace re:right-spaces str ""))
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define (trim-comments str)
(let ([positions (regexp-match-positions re:comments str)])
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str)))
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define (trim-comments str)
(let ([positions (regexp-match-positions re:comments str)])
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str)))
(define (lowercase str)
(let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out]
[else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 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 (lowercase str)
(let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out]
[else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 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 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

34
collects/net/mime.ss
View File

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

8
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@)
(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
(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@)
(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:
(module qp mzscheme
(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
#lang scheme/base
(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

8
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@)
(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
(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@)
(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
(provide make-ssl-tcp@)
(require mzlib/unit
"tcp-sig.ss"
(lib "mzssl.ss" "openssl")
mzlib/etc)
#lang scheme/base
(provide make-ssl-tcp@)
(require scheme/unit
"tcp-sig.ss"
openssl/mzssl)
(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 (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 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)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define (tcp-abandon-port p)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
(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-addresses ssl-addresses)
(define tcp-close ssl-close)
(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])
(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-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))
(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-listener? ssl-listener?)))

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

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

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

@ -1,6 +1,6 @@
(module tcp-unit mzscheme
(provide tcp@)
#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^)

218
collects/net/unihead.ss
View File

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