From a9acd2b5a3460621727655b327e73878661fe04d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 15 May 2008 16:55:15 +0000 Subject: [PATCH] reformatting svn: r9853 original commit: 0d41afdb6d470299616dd1db944ce4577c5a64bf --- collects/net/cgi.ss | 8 +- collects/net/cookie.ss | 8 +- collects/net/dns.ss | 8 +- collects/net/ftp.ss | 8 +- collects/net/imap.ss | 81 ++++++------ collects/net/mime-util.ss | 195 ++++++++++++++--------------- collects/net/mime.ss | 34 ++--- collects/net/nntp.ss | 8 +- collects/net/pop3.ss | 8 +- collects/net/qp.ss | 8 +- collects/net/sendmail.ss | 8 +- collects/net/smtp.ss | 8 +- collects/net/ssl-tcp-unit.ss | 106 ++++++++-------- collects/net/tcp-redirect.ss | 233 +++++++++++++++++------------------ collects/net/tcp-unit.ss | 8 +- collects/net/unihead.ss | 218 ++++++++++++++++---------------- 16 files changed, 467 insertions(+), 480 deletions(-) diff --git a/collects/net/cgi.ss b/collects/net/cgi.ss index 1dca70b60a..ff7afe44e5 100644 --- a/collects/net/cgi.ss +++ b/collects/net/cgi.ss @@ -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^) diff --git a/collects/net/cookie.ss b/collects/net/cookie.ss index 6b900fe299..449ec3ccae 100644 --- a/collects/net/cookie.ss +++ b/collects/net/cookie.ss @@ -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@) diff --git a/collects/net/dns.ss b/collects/net/dns.ss index 2169f09f93..6d58459ee4 100644 --- a/collects/net/dns.ss +++ b/collects/net/dns.ss @@ -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^) diff --git a/collects/net/ftp.ss b/collects/net/ftp.ss index 9685165d27..9a704ca76e 100644 --- a/collects/net/ftp.ss +++ b/collects/net/ftp.ss @@ -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^) diff --git a/collects/net/imap.ss b/collects/net/imap.ss index 8881a8ab49..cf99378297 100644 --- a/collects/net/imap.ss +++ b/collects/net/imap.ss @@ -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) diff --git a/collects/net/mime-util.ss b/collects/net/mime-util.ss index 2bdb219b68..bf5176810c 100644 --- a/collects/net/mime-util.ss +++ b/collects/net/mime-util.ss @@ -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 diff --git a/collects/net/mime.ss b/collects/net/mime.ss index 68a75cbdc5..43a6213c11 100644 --- a/collects/net/mime.ss +++ b/collects/net/mime.ss @@ -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 diff --git a/collects/net/nntp.ss b/collects/net/nntp.ss index 7162cc0cc4..015ebfc49f 100644 --- a/collects/net/nntp.ss +++ b/collects/net/nntp.ss @@ -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^) diff --git a/collects/net/pop3.ss b/collects/net/pop3.ss index e327b256a3..a303c61150 100644 --- a/collects/net/pop3.ss +++ b/collects/net/pop3.ss @@ -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^) #| diff --git a/collects/net/qp.ss b/collects/net/qp.ss index 346aef1b94..8dd2bc6fcb 100644 --- a/collects/net/qp.ss +++ b/collects/net/qp.ss @@ -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 diff --git a/collects/net/sendmail.ss b/collects/net/sendmail.ss index 19387b7a98..0b30111519 100644 --- a/collects/net/sendmail.ss +++ b/collects/net/sendmail.ss @@ -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^) diff --git a/collects/net/smtp.ss b/collects/net/smtp.ss index 8aa43caa13..8f97721449 100644 --- a/collects/net/smtp.ss +++ b/collects/net/smtp.ss @@ -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^) diff --git a/collects/net/ssl-tcp-unit.ss b/collects/net/ssl-tcp-unit.ss index bd31d15d15..175128433a 100644 --- a/collects/net/ssl-tcp-unit.ss +++ b/collects/net/ssl-tcp-unit.ss @@ -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?))) diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss index eb7327f03c..8f9c0635a3 100644 --- a/collects/net/tcp-redirect.ss +++ b/collects/net/tcp-redirect.ss @@ -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)) + + )) diff --git a/collects/net/tcp-unit.ss b/collects/net/tcp-unit.ss index de87f4f8cb..0ba7d9e503 100644 --- a/collects/net/tcp-unit.ss +++ b/collects/net/tcp-unit.ss @@ -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^) diff --git a/collects/net/unihead.ss b/collects/net/unihead.ss index 581e295a36..fb922a2e25 100644 --- a/collects/net/unihead.ss +++ b/collects/net/unihead.ss @@ -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))))