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^)

15
collects/net/imap.ss
View File

@ -1,18 +1,19 @@
(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
(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?)
. -> . (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
(provide
imap-connection?
imap-connect imap-connect*
imap-disconnect
@ -46,4 +47,4 @@
imap-mailbox-exists?
imap-create-mailbox
imap-mailbox-flags))
imap-mailbox-flags)

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

@ -26,10 +26,9 @@
;;
;; Commentary:
(module mime-util mzscheme
(require mzlib/etc)
#lang scheme/base
(provide string-tokenizer
(provide string-tokenizer
trim-all-spaces
trim-spaces
trim-comments
@ -37,29 +36,28 @@
warning
cat)
;; string-index returns the leftmost index in string s
;; that has character c
(define (string-index s c)
;; 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)
;; 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))))
(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)
;; 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)
@ -88,27 +86,27 @@
(car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))
;; Only trims left and right spaces:
(define (trim-spaces 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)
(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)
(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)
(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)
(define (lowercase str)
(let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out]
[else
@ -118,7 +116,7 @@
(substring rest 1 size)
(sub1 size))])))
(define warning
(define warning
void
#;
(lambda (msg . args)
@ -127,15 +125,12 @@
(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)))
;; 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))))))
)
(loop (read-line in)))))
;;; mime-util.ss ends here

16
collects/net/mime.ss
View File

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

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

@ -1,11 +1,10 @@
(module ssl-tcp-unit mzscheme
(provide make-ssl-tcp@)
(require mzlib/unit
#lang scheme/base
(provide make-ssl-tcp@)
(require scheme/unit
"tcp-sig.ss"
(lib "mzssl.ss" "openssl")
mzlib/etc)
openssl/mzssl)
(define (make-ssl-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
@ -37,15 +36,12 @@
(define tcp-addresses ssl-addresses)
(define tcp-close ssl-close)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define (tcp-connect hostname port-k)
(ssl-connect hostname port-k ctx))
(define (tcp-connect/enable-break hostname port-k)
(ssl-connect/enable-break hostname port-k ctx))
(define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
@ -58,6 +54,6 @@
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
l))
(define tcp-listener? ssl-listener?))))
(define tcp-listener? ssl-listener?)))

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

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

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^)

32
collects/net/unihead.ss
View File

@ -1,22 +1,22 @@
(module unihead mzscheme
(require net/base64
#lang mzscheme
(require net/base64
net/qp
mzlib/string)
(provide encode-for-header
(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)
(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 (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)])
@ -49,17 +49,17 @@
(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)
(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)
@ -71,7 +71,7 @@
(if (bytes? encoding) #"CP949" "CP949")]
[else encoding]))
(define (decode-for-header s)
(define (decode-for-header s)
(and s
(let ([m (regexp-match re:encoded
(string->bytes/latin-1 s (char->integer #\?)))])
@ -115,4 +115,4 @@
(subbytes rest 3)
rest)])
(decode-for-header (bytes->string/latin-1 rest))))))
s)))))
s))))