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

formatting etc

Browse Source 
svn: r5045
This commit is contained in:
Eli Barzilay 2006-12-06 21:23:38 +00:00
parent 216ac84f00
commit f17f7bc479
53 changed files with 4608 additions and 4791 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/net/base64-sig.ss
View File

@ -4,4 +4,3 @@
base64-decode-stream
base64-encode
base64-decode)

18
collects/net/base64-unit.ss
View File

@ -7,8 +7,7 @@
(define base64-digit (make-vector 256))
(let loop ([n 0])
(unless (= n 256)
(cond
[(<= (char->integer #\A) n (char->integer #\Z))
(cond [(<= (char->integer #\A) n (char->integer #\Z))
(vector-set! base64-digit n (- n (char->integer #\A)))]
[(<= (char->integer #\a) n (char->integer #\z))
(vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))]
@ -44,21 +43,18 @@
(let loop ([waiting 0][waiting-bits 0])
(if (>= waiting-bits 8)
(begin
(write-byte (arithmetic-shift waiting (- 8 waiting-bits))
out)
(write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out)
(let ([waiting-bits (- waiting-bits 8)])
(loop (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))
waiting-bits)))
(let* ([c0 (read-byte in)]
[c (if (eof-object? c0) (char->integer #\=) c0)]
[v (vector-ref base64-digit c)])
(cond
[v (loop (+ (arithmetic-shift waiting 6) v)
(cond [v (loop (+ (arithmetic-shift waiting 6) v)
(+ waiting-bits 6))]
[(eq? c (char->integer #\=)) (void)] ; done
[else (loop waiting waiting-bits)])))))
(define base64-encode-stream
(case-lambda
[(in out) (base64-encode-stream in out #"\n")]
@ -77,7 +73,7 @@
(display linesep out))])
(let loop ([pos 0])
(if (= pos 72)
; Insert newline
;; Insert newline
(begin
(display linesep out)
(loop 0))
@ -85,8 +81,7 @@
(let ([n (read-bytes-avail! three in)])
(cond
[(eof-object? n)
(unless (= pos 0)
(done 0))]
(unless (= pos 0) (done 0))]
[(= n 3)
;; Easy case:
(let ([a (bytes-ref three 0)]
@ -134,7 +129,6 @@
(define (base64-encode src)
(let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s
(bytes 13 10))
(base64-encode-stream (open-input-bytes src) s (bytes 13 10))
(get-output-bytes s))))

1
collects/net/cgi-sig.ss
View File

@ -20,4 +20,3 @@
string->html
generate-link-text
)

51
collects/net/cgi-unit.ss
View File

@ -29,9 +29,9 @@
;; -- The input is the characters post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX,
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
;; Scheme string with all the characters converted back.
;; spaces are turned into "+"es and lots of things are turned into %XX, where
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back.
(define (query-chars->string chars)
(list->string
@ -44,13 +44,11 @@
[(char=? first #\+)
(values #\space rest)]
[(char=? first #\%)
(if (and (pair? rest)
(pair? (cdr rest)))
(if (and (pair? rest) (pair? (cdr rest)))
(values
(integer->char
(or (string->number
(string
(car rest) (cadr rest))
(string (car rest) (cadr rest))
16)
(raise (make-invalid-%-suffix
(if (string->number
@ -59,8 +57,7 @@
(cadr rest)
(car rest))))))
(cddr rest))
(raise
(make-incomplete-%-suffix rest)))]
(raise (make-incomplete-%-suffix rest)))]
[else
(values first rest)])])
(cons this (loop rest))))))))
@ -69,7 +66,8 @@
;; -- the input is raw text, the output is HTML appropriately quoted
(define (string->html s)
(apply string-append (map (lambda (c)
(apply string-append
(map (lambda (c)
(case c
[(#\<) "&lt;"]
[(#\>) "&gt;"]
@ -123,9 +121,9 @@
(printf "Content-type: text/html\r\n\r\n"))
;; read-until-char : iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates
;; whether reading stopped because an EOF was hit (as opposed to the
;; delimiter being seen); the delimiter is not part of the result
;; -- operates on the default input port; the second value indicates whether
;; reading stopped because an EOF was hit (as opposed to the delimiter being
;; seen); the delimiter is not part of the result
(define (read-until-char ip delimiter)
(let loop ([chars '()])
(let ([c (read-char ip)])
@ -134,15 +132,15 @@
[else (loop (cons c chars))]))))
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is
;; true, indicating EOF was reached without any input seen. Otherwise,
;; the first and second values contain strings and the third is either
;; true or false depending on whether the EOF has been reached. The
;; strings are processed to remove the CGI spec "escape"s.
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
;; not clear this is legal by the CGI spec, which suggests that the last
;; value binding must end in an EOF. It doesn't look like this matters.
;; It would also introduce needless modality and reduce flexibility.
;; -- If the first value is false, so is the second, and the third is true,
;; indicating EOF was reached without any input seen. Otherwise, the first
;; and second values contain strings and the third is either true or false
;; depending on whether the EOF has been reached. The strings are processed
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
;; which suggests that the last value binding must end in an EOF. It doesn't
;; look like this matters. It would also introduce needless modality and
;; reduce flexibility.
(define (read-name+value ip)
(let-values ([(name eof?) (read-until-char ip #\=)])
(cond [(and eof? (null? name)) (values #f #f #t)]
@ -196,10 +194,10 @@
"</code>"))
;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics
;; of forms states that a CHECKBOX may use the same NAME field multiple
;; times. Hence, a list of strings is returned. Note that the result
;; may be the empty list.
;; -- Extracts the bindings associated with a given name. The semantics of
;; forms states that a CHECKBOX may use the same NAME field multiple times.
;; Hence, a list of strings is returned. Note that the result may be the
;; empty list.
(define (extract-bindings field-name bindings)
(let ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))])
@ -239,4 +237,3 @@
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
)

4
collects/net/cgi.ss
View File

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

1
collects/net/cookie-sig.ss
View File

@ -1,5 +1,4 @@
(module cookie-sig (lib "a-signature.ss")
set-cookie
cookie:add-comment
cookie:add-domain

192
collects/net/cookie-unit.ss
View File

@ -60,6 +60,14 @@
(define-struct cookie (name value comment domain max-age path secure version))
(define-struct (cookie-error exn:fail) ())
;; cookie-error : string args ... -> raises a cookie-error exception
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (cookie-error fmt . args)
(make-cookie-error
(string->immutable-string (apply format fmt args))
(current-continuation-marks)))
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
@ -72,19 +80,18 @@
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define set-cookie
(lambda (name pre-value)
(define (set-cookie name pre-value)
(let ([value (to-rfc2109:value pre-value)])
(unless (rfc2068:token? name)
(raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value))))
(cookie-error "Invalid cookie name: ~a / ~a" name value))
(make-cookie name value
#f;; comment
#f;; current domain
#f;; at the end of session
#f;; current path
#f;; normal (non SSL)
#f;; default version
))))
#f ; comment
#f ; current domain
#f ; at the end of session
#f ; current path
#f ; normal (non SSL)
#f ; default version
)))
;;!
;;
@ -94,73 +101,65 @@
;;
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
(define print-cookie
(lambda (cookie)
(define (print-cookie cookie)
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(string-join
(filter (lambda (s)
(not (string-null? s)))
(filter (lambda (s) (not (string-null? s)))
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
(let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
(let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
(let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
(let ((s (cookie-secure cookie))) (if s "Secure" ""))
(let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
"; ")))
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
(let ([s (cookie-secure cookie)]) (if s "Secure" ""))
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
"; "))
(define cookie:add-comment
(lambda (cookie pre-comment)
(define (cookie:add-comment cookie pre-comment)
(let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-comment! cookie comment)
cookie)))
cookie))
(define cookie:add-domain
(lambda (cookie domain)
(define (cookie:add-domain cookie domain)
(unless (valid-domain? domain)
(raise (build-cookie-error (format "Invalid domain: ~a" domain))))
(cookie-error "Invalid domain: ~a" domain))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-domain! cookie domain)
cookie))
cookie)
(define cookie:add-max-age
(lambda (cookie seconds)
(define (cookie:add-max-age cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds))))
(cookie-error "Invalid Max-Age for cookie: ~a" seconds))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-max-age! cookie seconds)
cookie))
cookie)
(define cookie:add-path
(lambda (cookie pre-path)
(define (cookie:add-path cookie pre-path)
(let ([path (to-rfc2109:value pre-path)])
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-path! cookie path)
cookie)))
cookie))
(define cookie:secure
(lambda (cookie secure?)
(define (cookie:secure cookie secure?)
(unless (boolean? secure?)
(raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?))))
(cookie-error "Invalid argument (boolean expected), received: ~a" secure?))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-secure! cookie secure?)
cookie))
cookie)
(define cookie:version
(lambda (cookie version)
(define (cookie:version cookie version)
(unless (integer? version)
(raise (build-cookie-error (format "Unsupported version: ~a" version))))
(cookie-error "Unsupported version: ~a" version))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-version! cookie version)
cookie))
cookie)
;; Parsing the Cookie header:
@ -177,27 +176,26 @@
;;
;; Auxiliar procedure that returns all values associated with
;; `name' in the association list (cookies).
(define get-all-results
(lambda (name cookies)
(let loop ((c cookies))
(cond ((null? c) ())
(else
(let ((pair (car c)))
(define (get-all-results name cookies)
(let loop ([c cookies])
(if (null? c)
'()
(let ([pair (car c)])
(if (string=? name (car pair))
;; found an instance of cookie named `name'
(cons (cadr pair) (loop (cdr c)))
(loop (cdr c)))))))))
(loop (cdr c)))))))
;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
;; note that it can be multi-valued: `test1' has values: "1", and "20".
;; Of course, in the same spirit, we only receive the "string content".
(define get-cookie
(lambda (name cookies)
(let ((cookies (map (lambda (p)
;; which typically looks like:
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
;; course, in the same spirit, we only receive the "string content".
(define (get-cookie name cookies)
(let ([cookies (map (lambda (p)
(map string-trim-both
(string-tokenize p char-set:all-but=)))
(string-tokenize cookies char-set:all-but-semicolon))))
(get-all-results name cookies))))
(string-tokenize cookies char-set:all-but-semicolon))])
(get-all-results name cookies)))
;;!
;;
@ -207,11 +205,9 @@
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define get-cookie/single
(lambda (name cookies)
(let ((cookies (get-cookie name cookies)))
(and (not (null? cookies))
(car cookies)))))
(define (get-cookie/single name cookies)
(let ([cookies (get-cookie name cookies)])
(and (not (null? cookies)) (car cookies))))
;;;;;
@ -232,13 +228,14 @@
(define char-set:control
(char-set-union char-set:iso-control
(char-set (integer->char 127))));; DEL
(define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
(define char-set:token
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
;; token? : string -> boolean
;;
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
(define rfc2068:token?
(lambda (s) (string-every char-set:token s)))
(define (rfc2068:token? s)
(string-every char-set:token s))
;;!
;;
@ -256,21 +253,22 @@
;; quoted-pair = "\" CHAR
;;
;; implementation note: I have chosen to use a regular expression rather than
;; a character set for this definition because of two dependencies: CRLF must appear
;; as a block to be legal, and " may only appear as \"
(define rfc2068:quoted-string?
(lambda (s)
(if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s)
;; a character set for this definition because of two dependencies: CRLF must
;; appear as a block to be legal, and " may only appear as \"
(define (rfc2068:quoted-string? s)
(if (regexp-match
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
s)
s
#f)))
#f))
;; value: token | quoted-string
(define (rfc2109:value? s)
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
;; convert-to-quoted : string -> quoted-string?
;; takes the given string as a particular message, and converts the given string to that
;; representatation
;; takes the given string as a particular message, and converts the given
;; string to that representatation
(define (convert-to-quoted str)
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
@ -278,7 +276,7 @@
(define (to-rfc2109:value s)
(cond
[(not (string? s))
(raise (build-cookie-error (format "Expected string, given: ~e" s)))]
(cookie-error "Expected string, given: ~e" s)]
;; for backwards compatibility, just use the given string if it will work
[(rfc2068:token? s) s]
@ -289,9 +287,7 @@
[(rfc2068:quoted-string? (convert-to-quoted s))
=> (λ (x) x)]
[else
(raise
(build-cookie-error
(format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
(cookie-error "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
;;!
;;
@ -304,7 +300,7 @@
(define cookie-string?
(opt-lambda (s (value? #t))
(unless (string? s)
(raise (build-cookie-error (format "String expected, received: ~a" s))))
(cookie-error "String expected, received: ~a" s))
(if value?
(rfc2109:value? s)
;; name: token
@ -312,31 +308,21 @@
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
(let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
(a-z-uppercase (ucs-range->char-set #x41 #x5B)))
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
#\. )))
#\.)))
(define valid-domain?
(lambda (dom)
(and
;; Domain must start with a dot (.)
(define (valid-domain? dom)
(and ;; Domain must start with a dot (.)
(string=? (string-take dom 1) ".")
;; The rest are tokens-like strings separated by dots
(string-every char-set:hostname dom)
(<= (string-length dom) 76))))
(<= (string-length dom) 76)))
(define (valid-path? v)
(and (string? v)
(rfc2109:value? v)))
;; build-cookie-error : string -> cookie-error
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (build-cookie-error msg)
(make-cookie-error (string->immutable-string msg)
(current-continuation-marks)))
(and (string? v) (rfc2109:value? v)))
)

4
collects/net/cookie.ss
View File

@ -1,7 +1,5 @@
(module cookie mzscheme
(require (lib "unit.ss")
"cookie-sig.ss"
"cookie-unit.ss")
(require (lib "unit.ss") "cookie-sig.ss" "cookie-unit.ss")
(provide-signature-elements cookie^)

1
collects/net/dns-sig.ss
View File

@ -3,4 +3,3 @@
dns-get-name
dns-get-mail-exchanger
dns-find-nameserver)

140
collects/net/dns-unit.ss
View File

@ -1,8 +1,5 @@
(module dns-unit (lib "a-unit.ss")
(require (lib "list.ss")
(lib "process.ss")
"dns-sig.ss")
(require (lib "list.ss") (lib "process.ss") "dns-sig.ss")
(import)
(export dns^)
@ -35,20 +32,16 @@
(hs 4)))
(define (cossa i l)
(cond
[(null? l) #f]
[(equal? (cadar l) i)
(car l)]
(cond [(null? l) #f]
[(equal? (cadar l) i) (car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (octet-pair->number a b)
(+ (arithmetic-shift a 8)
b))
(+ (arithmetic-shift a 8) b))
(define (octet-quad->number a b c d)
(+ (arithmetic-shift a 24)
@ -58,22 +51,15 @@
(define (name->octets s)
(let ([do-one (lambda (s)
(cons
(bytes-length s)
(bytes->list s)))])
(cons (bytes-length s) (bytes->list s)))])
(let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m
(append
(do-one (cadr m))
(loop (caddr m)))
(append
(do-one s)
(list 0)))))))
(append (do-one (cadr m)) (loop (caddr m)))
(append (do-one s) (list 0)))))))
(define (make-std-query-header id question-count)
(append
(number->octet-pair id)
(append (number->octet-pair id)
(list 1 0) ; Opcode & flags (recusive flag set)
(number->octet-pair question-count)
(number->octet-pair 0)
@ -81,8 +67,7 @@
(number->octet-pair 0)))
(define (make-query id name type class)
(append
(make-std-query-header id 1)
(append (make-std-query-header id 1)
(name->octets name)
(number->octet-pair (cadr (assoc type types)))
(number->octet-pair (cadr (assoc class classes)))))
@ -112,43 +97,50 @@
[(zero? len)
(let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse! accum))])
(values (if s
(bytes-append s0 #"." s)
s0)
(values (if s (bytes-append s0 #"." s) s0)
start)))]
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
[else
;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(cadr start))])
(let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
(let-values ([(s ignore-start)
(parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-rr start reply)
(let-values ([(name start) (parse-name start reply)])
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
[start (cddr start)])
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
[start (cddr start)])
(let ([ttl (octet-quad->number (car start) (cadr start)
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
[start (cddr start)]
;;
[class (car (cossa (octet-pair->number (car start) (cadr start))
classes))]
[start (cddr start)]
;;
[ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start))]
[start (cddddr start)])
(let ([len (octet-pair->number (car start) (cadr start))]
[start (cddddr start)]
;;
[len (octet-pair->number (car start) (cadr start))]
[start (cddr start)])
; Extract next len bytes for data:
(let loop ([len len][start start][accum null])
;; Extract next len bytes for data:
(let loop ([len len] [start start] [accum null])
(if (zero? len)
(values (list name type class ttl (reverse! accum))
start)
(loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
(define (parse-ques start reply)
(let-values ([(name start) (parse-name start reply)])
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
[start (cddr start)]
;;
[class (car (cossa (octet-pair->number (car start) (cadr start))
classes))]
[start (cddr start)])
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
[start (cddr start)])
(values (list name type class) start)))))
(values (list name type class) start))))
(define (parse-n parse start reply n)
(let loop ([n n][start start][accum null])
@ -163,19 +155,17 @@
(unless (assoc class classes)
(raise-type-error 'dns-query "DNS query class" class))
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr) type class)]
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
type class)]
[udp (udp-open-socket)]
[reply
(dynamic-wind
void
(lambda ()
(let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query))
(sync
(handle-evt
(sync (handle-evt
(udp-receive!-evt udp s)
(lambda (r)
(bytes->list (subbytes s 0 (car r)))))
@ -184,18 +174,16 @@
timeout))
(lambda (v)
(retry (* timeout 2))))))))
(lambda () (udp-close udp)))])
(lambda ()
(udp-close udp)))])
; First two bytes must match sent message id:
;; First two bytes must match sent message id:
(unless (and (= (car reply) (car query))
(= (cadr reply) (cadr query)))
(error 'dns-query "bad reply id from server"))
(let ([v0 (caddr reply)]
[v1 (cadddr reply)])
; Check for error code:
;; Check for error code:
(let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode)
(error 'dns-query "error from server: ~a"
@ -233,19 +221,15 @@
(define (ip->string s)
(format "~a.~a.~a.~a"
(list-ref s 0)
(list-ref s 1)
(list-ref s 2)
(list-ref s 3)))
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
(define (try-forwarding k nameserver)
(let loop ([nameserver nameserver][tried (list nameserver)])
; Normally the recusion is done for us, but it's technically optional
;; Normally the recusion is done for us, but it's technically optional
(let-values ([(v ars auth?) (k nameserver)])
(or v
(and (not auth?)
(let* ([ns (ormap
(lambda (ar)
(let* ([ns (ormap (lambda (ar)
(and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar))))
ars)])
@ -253,40 +237,35 @@
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(define ip->in-addr.arpa
(lambda (ip)
(let ((result (regexp-match "([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)" ip)))
(define (ip->in-addr.arpa ip)
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
ip)])
(format "~a.~a.~a.~a.in-addr.arpa"
(list-ref result 4)
(list-ref result 3)
(list-ref result 2)
(list-ref result 1)))))
(list-ref result 1))))
(define get-ptr-list-from-ans
(lambda (ans)
(filter (lambda (ans-entry)
(eq? (list-ref ans-entry 1) 'ptr))
ans)))
(define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
ans))
(define dns-get-name
(lambda (nameserver ip)
(define (dns-get-name nameserver ip)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply)
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
(values (and (positive? (length (get-ptr-list-from-ans ans)))
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
(let-values (((name null) (parse-name s reply)))
(let-values ([(name null) (parse-name s reply)])
(bytes->string/latin-1 name))))
ars auth?)))
nameserver)
(error 'dns-get-name "bad ip address"))))
(error 'dns-get-name "bad ip address")))
(define get-a-list-from-ans
(lambda (ans)
(filter (lambda (ans-entry)
(eq? (list-ref ans-entry 1) 'a))
ans)))
(define (get-a-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
ans))
(define (dns-get-address nameserver addr)
(or (try-forwarding
@ -305,10 +284,10 @@
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
(cond
[(null? ans) (or exchanger
[(null? ans)
(or exchanger
;; Does 'soa mean that the input address is fine?
(and (ormap
(lambda (ns) (eq? (rr-type ns) 'soa))
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
nss)
addr))]
[else
@ -362,4 +341,3 @@
=> (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))]
[else #f])))

4
collects/net/dns.ss
View File

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

1
collects/net/ftp-sig.ss
View File

@ -5,4 +5,3 @@
ftp-directory-list
ftp-download-file
ftp-make-file-seconds)

98
collects/net/ftp-unit.ss
View File

@ -3,10 +3,7 @@
;; Version 0.1a
;; Micah Flatt
;; 06-06-2002
(require (lib "date.ss")
(lib "file.ss")
(lib "port.ss")
"ftp-sig.ss")
(require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss")
(import)
(export ftp^)
@ -51,8 +48,7 @@
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
@ -65,19 +61,12 @@
(error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes)
(cond
[(equal? #"Jan" month-bytes) 1]
[(equal? #"Feb" month-bytes) 2]
[(equal? #"Mar" month-bytes) 3]
[(equal? #"Apr" month-bytes) 4]
[(equal? #"May" month-bytes) 5]
[(equal? #"Jun" month-bytes) 6]
[(equal? #"Jul" month-bytes) 7]
[(equal? #"Aug" month-bytes) 8]
[(equal? #"Sep" month-bytes) 9]
[(equal? #"Oct" month-bytes) 10]
[(equal? #"Nov" month-bytes) 11]
[(equal? #"Dec" month-bytes) 12]))
(cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12)))
=> cadr]
[else (error 'get-month "bad month: ~s" month-bytes)]))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
@ -104,11 +93,12 @@
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV~n")
(let ([response (ftp-check-response (tcp-connection-in tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV\n")
(let ([response (ftp-check-response
(tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ;; should be the only response
(lambda (s ignore) s) ; should be the only response
(void))])
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
@ -116,13 +106,14 @@
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out) (tcp-connect (format "~a.~a.~a.~a"
(let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(fprintf (tcp-connection-out tcp-ports) "TYPE I~n")
(fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"200" void (void))
@ -131,18 +122,20 @@
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a~n" s)
;; (printf "~a\n" s)
(void))
(define (ftp-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response in out (list #"331" #"230")
(let ([no-password? (ftp-check-response
in out (list #"331" #"230")
(lambda (line 230?)
(or 230? (regexp-match #rx#"^230" line)))
#f)])
(unless no-password?
(display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out)
(display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
out)
(ftp-check-response in out #"230" void (void))))
(make-tcp-connection in out))
@ -151,21 +144,20 @@
(ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "QUIT~n")
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"221" void (void))
(fprintf (tcp-connection-out tcp-ports) "QUIT\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"221" void (void))
(close-input-port (tcp-connection-in tcp-ports))
(close-output-port (tcp-connection-out tcp-ports)))
(define (filter-tcp-data tcp-data-port regular-exp)
(let loop ()
(let ([theline (read-bytes-line tcp-data-port 'any)])
(cond
[(or (eof-object? theline)
(< (bytes-length theline) 3))
(cond [(or (eof-object? theline) (< (bytes-length theline) 3))
null]
[(regexp-match regular-exp theline)
=> (lambda (m)
(cons (cdr m) (loop)))]
=> (lambda (m) (cons (cdr m) (loop)))]
[else
;; ignore unrecognized lines?
(loop)]))))
@ -173,43 +165,53 @@
(define (ftp-cd ftp-ports new-dir)
(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
(tcp-connection-out ftp-ports))
(ftp-check-response (tcp-connection-in ftp-ports) (tcp-connection-out ftp-ports)
(ftp-check-response (tcp-connection-in ftp-ports)
(tcp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define re:dir-line
#rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define (ftp-directory-list tcp-ports)
(let ([tcp-data (establish-data-connection tcp-ports)])
(fprintf (tcp-connection-out tcp-ports) "LIST~n")
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "LIST\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" void (void))
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(map (lambda (l) (map bytes->string/locale l)) dir-list))))
(define (ftp-download-file tcp-ports folder filename)
;; Save the file under the name tmp.file,
;; rename it once download is complete
;; this assures we don't over write any existing file without having a good file down
(let* ([tmpfile (make-temporary-file (string-append
(regexp-replace #rx"~"
;; Save the file under the name tmp.file, rename it once download is
;; complete this assures we don't over write any existing file without
;; having a good file down
(let* ([tmpfile (make-temporary-file
(string-append
(regexp-replace
#rx"~"
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile 'replace)]
[tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")]
[tcpstring (bytes-append #"RETR "
(string->bytes/locale filename)
#"\n")]
[tcp-data (establish-data-connection tcp-ports)])
(display tcpstring (tcp-connection-out tcp-ports))
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (printf "FTP Client Installed...~n")
;; (printf "FTP Client Installed...\n")
)

4
collects/net/ftp.ss
View File

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

1
collects/net/head-sig.ss
View File

@ -11,4 +11,3 @@
data-lines->data
extract-addresses
assemble-address-field)

138
collects/net/head-unit.ss
View File

@ -1,15 +1,14 @@
(module head-unit (lib "a-unit.ss")
(require (lib "date.ss")
(lib "string.ss")
"head-sig.ss")
(require (lib "date.ss") (lib "string.ss") "head-sig.ss")
(import)
(export head^)
;; NB: I've done a copied-code adaptation of a number of these definitions into
;; "bytes-compatible" versions. Finishing the rest will require some kind of interface
;; decision---that is, when you don't supply a header, should the resulting operation
;; be string-centric or bytes-centric? Easiest just to stop here.
;; NB: I've done a copied-code adaptation of a number of these definitions
;; into "bytes-compatible" versions. Finishing the rest will require some
;; kind of interface decision---that is, when you don't supply a header,
;; should the resulting operation be string-centric or bytes-centric?
;; Easiest just to stop here.
;; -- JBC 2006-07-31
(define CRLF (string #\return #\newline))
@ -24,7 +23,6 @@
(define re:continue (regexp "^[ \t\v]"))
(define re:continue/bytes #rx#"^[ \t\v]")
(define (validate-header s)
(if (bytes? s)
;; legal char check not needed per rfc 2822, IIUC.
@ -70,11 +68,9 @@
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(define (extract-field field header)
(if (bytes? header)
(let ([m (regexp-match-positions
(make-field-start-regexp/bytes field)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(and m
(let ([s (subbytes header
@ -84,12 +80,9 @@
(if m
(subbytes s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx#"\r\n\r\n$"
s
""))))))
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
;; otherwise header & field should be strings:
(let ([m (regexp-match-positions
(make-field-start-regexp field)
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(and m
(let ([s (substring header
@ -99,58 +92,30 @@
(if m
(substring s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$"
s
""))))))))
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions
(make-field-start-regexp/bytes field)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(if m
(let ([pre (subbytes header
0
(caaddr m))]
[s (subbytes header
(cdaddr m)
(bytes-length header))])
(let* ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m
(subbytes s (+ 2 (caar m))
(bytes-length s))
empty-header/bytes)])
(bytes-append pre
(if data
(insert-field field data rest)
rest))))
(if data
(insert-field field data header)
header)))
(let* ([pre (subbytes header 0 (caaddr m))]
[s (subbytes header (cdaddr m))]
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
(bytes-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions
(make-field-start-regexp field)
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(if m
(let ([pre (substring header
0
(caaddr m))]
[s (substring header
(cdaddr m)
(string-length header))])
(let* ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m
(substring s (+ 2 (caar m))
(string-length s))
empty-header)])
(string-append pre
(if data
(insert-field field data rest)
rest))))
(if data
(insert-field field data header)
header)))))
(let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))]
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
(string-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))))
(define (remove-field field header)
(replace-field field #f header))
@ -160,12 +125,9 @@
(let ([field (bytes-append field #": "data #"\r\n")])
(bytes-append field header))
;; otherwise field, data, & header should be strings:
(let ([field (format "~a: ~a\r\n"
field
data)])
(let ([field (format "~a: ~a\r\n" field data)])
(string-append field header))))
(define (append-headers a b)
(if (bytes? a)
(let ([alen (bytes-length a)])
@ -185,7 +147,8 @@
(let ([m (regexp-match-positions re header start)])
(if m
(let ([start (cdaddr m)]
[field-name (subbytes header (caaddr (cdr m)) (cdaddr (cdr m)))])
[field-name (subbytes header (caaddr (cdr m))
(cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx#"\r\n[^: \r\n\"]*:"
header
@ -210,9 +173,7 @@
(let ([start (cdaddr m)]
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx"\r\n[^: \r\n\"]*:"
header
start)])
#rx"\r\n[^: \r\n\"]*:" header start)])
(if m2
(cons (cons field-name
(substring header start (caar m2)))
@ -226,9 +187,9 @@
;; malformed header:
null))))))
;; It's slightly less obvious how to generalize the functions that don't accept a header
;; as input; for lack of an obvious solution (and free time), I'm stopping the string->bytes
;; translation here. -- JBC, 2006-07-31
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
@ -237,31 +198,22 @@
"Date" (parameterize ([date-display-format 'rfc2822])
(date->string (seconds->date (current-seconds)) #t))
CRLF))])
;; NOTE: bccs don't go into the header; that's why
;; they're "blind"
;; NOTE: bccs don't go into the header; that's why they're "blind"
(let ([h (if (null? ccs)
h
(insert-field
"CC" (assemble-address-field ccs)
h))])
(insert-field "CC" (assemble-address-field ccs) h))])
(let ([h (if (null? tos)
h
(insert-field
"To" (assemble-address-field tos)
h))])
(insert-field
"From" from
h)))))
(insert-field "To" (assemble-address-field tos) h))])
(insert-field "From" from h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply
string-append
(map
(lambda (n) (format "~a~a" sep n))
(apply string-append
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
@ -337,10 +289,9 @@
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result form
(if (string=? (car all) (cadr all))
name
(car all))
(select-result
form
(if (string=? (car all) (cadr all)) name (car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
@ -357,8 +308,7 @@
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else
(one-result form (extract-simple-addr s orig))])))
[else (one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
@ -369,13 +319,11 @@
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(cond
[(regexp-match re:bad-chars s)
(cond [(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace
re:tail-blanks
(regexp-replace re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))

4
collects/net/head.ss
View File

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

1
collects/net/imap-sig.ss
View File

@ -35,4 +35,3 @@
imap-list-child-mailboxes
imap-mailbox-flags
imap-get-hierarchy-delimiter)

161
collects/net/imap-unit.ss
View File

@ -1,35 +1,28 @@
(module imap-unit (lib "a-unit.ss")
(require (lib "list.ss")
"imap-sig.ss"
"private/rbtree.ss")
(require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss")
(import)
(export imap^)
(define debug-via-stdio? #f)
(define eol (if debug-via-stdio?
'linefeed
'return-linefeed))
(define eol (if debug-via-stdio? 'linefeed 'return-linefeed))
(define (tag-eq? a b)
(or (eq? a b)
(and (symbol? a)
(symbol? b)
(string-ci=? (symbol->string a)
(symbol->string b)))))
(string-ci=? (symbol->string a) (symbol->string b)))))
(define field-names
(list
(list 'uid (string->symbol "UID"))
(list (list 'uid (string->symbol "UID"))
(list 'header (string->symbol "RFC822.HEADER"))
(list 'body (string->symbol "RFC822.TEXT"))
(list 'size (string->symbol "RFC822.SIZE"))
(list 'flags (string->symbol "FLAGS"))))
(define flag-names
(list
(list 'seen (string->symbol "\\Seen"))
(list (list 'seen (string->symbol "\\Seen"))
(list 'answered (string->symbol "\\Answered"))
(list 'flagged (string->symbol "\\Flagged"))
(list 'deleted (string->symbol "\\Deleted"))
@ -45,15 +38,11 @@
(list 'haschildren (string->symbol "\\HasChildren"))))
(define (imap-flag->symbol f)
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
flag-names)
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names)
f))
(define (symbol->imap-flag s)
(let ([a (assoc s flag-names)])
(if a
(cadr a)
s)))
(cond [(assoc s flag-names) => cadr] [else s]))
(define (log-warning . args)
;; (apply printf args)
@ -63,8 +52,7 @@
(define make-msg-id
(let ([id 0])
(lambda ()
(begin0
(string->bytes/latin-1 (format "a~a " id))
(begin0 (string->bytes/latin-1 (format "a~a " id))
(set! id (add1 id))))))
(define (starts-with? l n)
@ -72,20 +60,15 @@
(bytes=? n (subbytes l 0 (bytes-length n)))))
(define (skip s n)
(subbytes s
(if (number? n) n (bytes-length n))
(bytes-length s)))
(subbytes s (if (number? n) n (bytes-length n))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply
string-append
(map
(lambda (n) (format "~a~a" sep n))
(cdr l))))))
(apply string-append
(map (lambda (n) (format "~a~a" sep n)) (cdr l))))))
(define (imap-read s r)
(let loop ([s s]
@ -144,17 +127,16 @@
(define (get-response r id info-handler continuation-handler)
(let loop ()
(let ([l (read-bytes-line r eol)])
(log "raw-reply: ~s~n" l)
(cond
[(eof-object? l)
(log "raw-reply: ~s\n" l)
(cond [(eof-object? l)
(error 'imap-send "unexpected end-of-file from server")]
[(and id (starts-with? l id))
(let ([reply (imap-read (skip l id) r)])
(log "response: ~a~n" reply)
(log "response: ~a\n" reply)
reply)]
[(starts-with? l #"* ")
(let ([info (imap-read (skip l 2) r)])
(log "info: ~s~n" info)
(log "info: ~s\n" info)
(info-handler info))
(when id
(loop))]
@ -163,9 +145,8 @@
(error 'imap-send "unexpected continuation request: ~a" l)
((car continuation-handler) loop (imap-read (skip l 2) r)))]
[else
(log-warning "warning: unexpected response for ~a: ~a~n" id l)
(when id
(loop))]))))
(log-warning "warning: unexpected response for ~a: ~a\n" id l)
(when id (loop))]))))
;; A cmd is
;; * (box v) - send v literally via ~a
@ -177,13 +158,14 @@
(let ([r (imap-r imap)]
[w (imap-w imap)]
[id (make-msg-id)])
(log "sending ~a~a~n" id cmd)
(log "sending ~a~a\n" id cmd)
(fprintf w "~a" id)
(let loop ([cmd cmd])
(cond
[(box? cmd) (fprintf w "~a" (unbox cmd))]
[(string? cmd) (loop (string->bytes/utf-8 cmd))]
[(bytes? cmd) (if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
[(bytes? cmd)
(if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
(equal? cmd #""))
(if (regexp-match #rx#"[\"\r\n]" cmd)
(begin
@ -202,11 +184,11 @@
(loop (cdr cmd)))]))
(fprintf w "\r\n")
(flush-output w)
(get-response r id (wrap-info-handler imap info-handler) continuation-handler)))
(get-response r id (wrap-info-handler imap info-handler)
continuation-handler)))
(define (check-ok reply)
(unless (and (pair? reply)
(tag-eq? (car reply) 'OK))
(unless (and (pair? reply) (tag-eq? (car reply) 'OK))
(error 'check-ok "server error: ~s" reply)))
(define (ok-tag-eq? i t)
@ -233,7 +215,7 @@
(set-imap-recent! imap (car i))]
[(tag-eq? (cadr i) 'EXPUNGE)
(let ([n (car i)])
(log "Recording expunge: ~s~n" n)
(log "Recording expunge: ~s\n" n)
;; add it to the tree of expunges
(expunge-insert! (imap-expunges imap) n)
;; decrement exists count:
@ -241,7 +223,8 @@
;; adjust ids for any remembered fetches:
(fetch-shift! (imap-fetches imap) n))]
[(tag-eq? (cadr i) 'FETCH)
(fetch-insert! (imap-fetches imap)
(fetch-insert!
(imap-fetches imap)
;; Convert result to assoc list:
(cons (car i)
(let ([new
@ -267,12 +250,12 @@
(set-imap-uidvalidity! imap (ok-tag-val i))]))
(info-handler i)))
(define-struct imap (r w
exists recent unseen uidnext uidvalidity
(define-struct imap (r w exists recent unseen uidnext uidvalidity
expunges fetches new?))
(define (imap-connection? v) (imap? v))
(define imap-port-number (make-parameter 143
(define imap-port-number
(make-parameter 143
(lambda (v)
(unless (and (number? v)
(exact? v)
@ -290,24 +273,23 @@
(close-output-port w)
(raise x))])
(let ([imap (make-imap r w
#f #f #f #f #f
(let ([imap (make-imap r w #f #f #f #f #f
(new-tree) (new-tree) #f)])
(check-ok (imap-send imap "NOOP" void))
(let ([reply (imap-send imap (list "LOGIN" username password) void)])
(if (and (pair? reply) (tag-eq? 'NO (car reply)))
(error 'imap-connect "username or password rejected by server: ~s" reply)
(error 'imap-connect
"username or password rejected by server: ~s" reply)
(check-ok reply)))
(let-values ([(init-count init-recent) (imap-reselect imap inbox)])
(values imap
init-count
init-recent)))))
(values imap init-count init-recent)))))
(define (imap-connect server username password inbox)
;; => imap count-k recent-k
(let-values ([(r w) (if debug-via-stdio?
(let-values ([(r w)
(if debug-via-stdio?
(begin
(printf "stdin == ~a~n" server)
(printf "stdin == ~a\n" server)
(values (current-input-port) (current-output-port)))
(tcp-connect server (imap-port-number)))])
(imap-connect* r w username password inbox)))
@ -339,14 +321,12 @@
flags))
(raise-type-error 'imap-status "list of status flag symbols" flags))
(let ([results null])
(check-ok (imap-send imap (list "STATUS" inbox
(box (format "~a" flags)))
(check-ok (imap-send imap (list "STATUS" inbox (box (format "~a" flags)))
(lambda (i)
(when (and (list? i) (= 3 (length i))
(tag-eq? (car i) 'STATUS))
(set! results (caddr i))))))
(map
(lambda (f)
(map (lambda (f)
(let loop ([l results])
(cond
[(or (null? l) (null? (cdr l))) #f]
@ -355,14 +335,13 @@
flags)))
(define (imap-poll imap)
;; Check for async messages from the server
(when (char-ready? (imap-r imap))
(when (and ;; Check for async messages from the server
(char-ready? (imap-r imap))
;; It has better start with "*"...
(when (= (peek-byte (imap-r imap))
(char->integer #\*))
(= (peek-byte (imap-r imap)) (char->integer #\*)))
;; May set fields in `imap':
(get-response (imap-r imap) #f (wrap-info-handler imap void) null)
(void))))
(void)))
(define (imap-get-updates imap)
(no-expunges 'imap-updates imap)
@ -402,9 +381,7 @@
(define (no-expunges who imap)
(unless (tree-empty? (imap-expunges imap))
(raise-mismatch-error who
"session has pending expunge reports: "
imap)))
(raise-mismatch-error who "session has pending expunge reports: " imap)))
(define (imap-get-messages imap msgs field-list)
(no-expunges 'imap-get-messages imap)
@ -420,15 +397,18 @@
null
(begin
;; FETCH request adds info to `(imap-fectches imap)':
(imap-send imap (list "FETCH"
(imap-send imap
(list "FETCH"
(box (splice msgs ","))
(box
(format "(~a)"
(splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))))
(splice (map (lambda (f)
(cadr (assoc f field-names)))
field-list)
" "))))
void)
;; Sort out the collected info:
(let ([flds (map (lambda (f)
(cadr (assoc f field-names)))
(let ([flds (map (lambda (f) (cadr (assoc f field-names)))
field-list)])
(begin0
;; For each msg, try to get each field value:
@ -445,11 +425,8 @@
null]
[else
(let ([a (assoc (car flds) m)])
(cons
(and a (cdr a))
(loop (cdr flds) (if a
(remq a m)
m))))]))))
(cons (and a (cdr a))
(loop (cdr flds) (if a (remq a m) m))))]))))
msgs))))))
(define (imap-store imap mode msgs flags)
@ -463,19 +440,14 @@
[(-) "-FLAGS.SILENT"]
[(!) "FLAGS.SILENT"]
[else (raise-type-error
'imap-store
"mode: '!, '+, or '-"
mode)])
'imap-store "mode: '!, '+, or '-" mode)])
(box (format "~a" flags)))
void)))
(define (imap-copy imap msgs dest-mailbox)
(no-expunges 'imap-copy imap)
(check-ok
(imap-send imap
(list "COPY"
(box (splice msgs ","))
dest-mailbox)
(imap-send imap (list "COPY" (box (splice msgs ",")) dest-mailbox)
void)))
(define (imap-append imap dest-mailbox msg)
@ -499,9 +471,7 @@
(define (imap-mailbox-exists? imap mailbox)
(let ([exists? #f])
(check-ok (imap-send imap
(list "LIST"
""
mailbox)
(list "LIST" "" mailbox)
(lambda (i)
(when (and (pair? i)
(tag-eq? (car i) 'LIST))
@ -509,18 +479,14 @@
exists?))
(define (imap-create-mailbox imap mailbox)
(check-ok
(imap-send imap
(list "CREATE" mailbox)
void)))
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
(define (imap-get-hierarchy-delimiter imap)
(let* ([result #f])
(check-ok
(imap-send imap (list "LIST" "" "")
(lambda (i)
(when (and (pair? i)
(tag-eq? (car i) 'LIST))
(when (and (pair? i) (tag-eq? (car i) 'LIST))
(set! result (caddr i))))))
result))
@ -537,9 +503,12 @@
(map (lambda (p)
(list (car p)
(cond
[(symbol? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
[(string? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
[(bytes? (cadr p)) (cadr p)])))
[(symbol? (cadr p))
(string->bytes/utf-8 (symbol->string (cadr p)))]
[(string? (cadr p))
(string->bytes/utf-8 (symbol->string (cadr p)))]
[(bytes? (cadr p))
(cadr p)])))
(imap-list-mailboxes imap pattern mailbox-name)))]))
(define (imap-mailbox-flags imap mailbox)
@ -565,7 +534,5 @@
(unless (and except
(bytes=? bytes-name except))
(set! sub-folders
(cons
(list flags name)
sub-folders))))))))
(cons (list flags name) sub-folders))))))))
(reverse sub-folders))))

5
collects/net/imap.ss
View File

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

276
collects/net/mime-unit.ss
View File

@ -41,31 +41,35 @@
(export mime^)
;; Constants:
(define discrete-alist '(("text" . text)
(define discrete-alist
'(("text" . text)
("image" . image)
("audio" . audio)
("video" . video)
("application" . application)))
(define disposition-alist '(("inline" . inline)
(define disposition-alist
'(("inline" . inline)
("attachment" . attachment)
("file" . attachment) ;; This is used
;; (don't know why)
;; by multipart/form-data
("file" . attachment) ;; This is used (don't know why) by
;; multipart/form-data
("messagetext" . inline)
("form-data" . form-data)))
(define composite-alist '(("message" . message)
(define composite-alist
'(("message" . message)
("multipart" . multipart)))
(define mechanism-alist '(("7bit" . 7bit)
(define mechanism-alist
'(("7bit" . 7bit)
("8bit" . 8bit)
("binary" . binary)
("quoted-printable" . quoted-printable)
("base64" . base64)))
(define ietf-extensions '())
(define iana-extensions '(;; text
(define iana-extensions
'(;; text
("plain" . plain)
("html" . html)
("enriched" . enriched) ; added 5/2005 - probably not iana
@ -118,7 +122,8 @@
;; Basic structures
(define-struct message (version entity fields))
(define-struct entity
(type subtype charset encoding disposition params id description other fields parts body))
(type subtype charset encoding disposition params id description other
fields parts body))
(define-struct disposition
(type filename creation modification read size params))
@ -139,17 +144,17 @@
(define CRLF-binary "=0D=0A") ;; quoted printable representation
;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822,
;; and rfc2045.
;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045.
(define get-headers
(lambda (in)
(let loop ((headers "") (ln (read-line in 'any)))
(cond ((eof-object? ln)
(let loop ([headers ""] [ln (read-line in 'any)])
(cond [(eof-object? ln)
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
(warning "premature eof while parsing headers")
headers)
((string=? ln "") headers)
(else
headers]
[(string=? ln "") headers]
[else
;; Quoting rfc822:
;; " Headers occur before the message body and are
;; terminated by a null line (i.e., two contiguous
@ -158,7 +163,7 @@
;; the CRLF ending the last field (header) as the first
;; CRLF of the null line.
(loop (string-append headers ln CRLF)
(read-line in 'any)))))))
(read-line in 'any))]))))
(define make-default-disposition
(lambda ()
@ -198,33 +203,33 @@
(set-entity-body!
entity
(case (entity-encoding entity)
((quoted-printable)
[(quoted-printable)
(lambda (output)
(qp-decode-stream input output)))
((base64)
(qp-decode-stream input output))]
[(base64)
(lambda (output)
(base64-decode-stream input output)))
(else ;; 7bit, 8bit, binary
(base64-decode-stream input output))]
[else ;; 7bit, 8bit, binary
(lambda (output)
(copy-port input output)))))))
(copy-port input output))]))))
(define mime-analyze
(opt-lambda (input (part #f))
(let* ((iport (if (bytes? input)
(let* ([iport (if (bytes? input)
(open-input-bytes input)
input))
(headers (get-headers iport))
(msg (if part
input)]
[headers (get-headers iport)]
[msg (if part
(MIME-part-headers headers)
(MIME-message-headers headers)))
(entity (message-entity msg)))
(MIME-message-headers headers))]
[entity (message-entity msg)])
;; OK we have in msg a MIME-message structure, lets see what we have:
(case (entity-type entity)
((text image audio video application)
[(text image audio video application)
;; decode part, and save port and thunk
(mime-decode entity iport))
((message multipart)
(let ((boundary (entity-boundary entity)))
(mime-decode entity iport)]
[(message multipart)
(let ([boundary (entity-boundary entity)])
(when (not boundary)
(if (eq? 'multipart (entity-type entity))
(raise (make-missing-multipart-boundary-parameter))))
@ -233,20 +238,18 @@
(mime-analyze part #t))
(if boundary
(multipart-body iport boundary)
(list iport))))))
(else
(list iport)))))]
[else
;; Unrecognized type, you're on your own! (sorry)
(mime-decode entity iport)))
(mime-decode entity iport)])
;; return mime structure
msg)))
(define entity-boundary
(lambda (entity)
(let* ((params (entity-params entity))
(ans (assoc "boundary" params)))
(and ans
(cdr ans)))))
(let* ([params (entity-params entity)]
[ans (assoc "boundary" params)])
(and ans (cdr ans)))))
;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
@ -263,22 +266,22 @@
(let* ([make-re (lambda (prefix)
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
[re (make-re "\r\n")])
(letrec ((eat-part (lambda ()
(letrec ([eat-part (lambda ()
(let-values ([(pin pout) (make-pipe)])
(let ([m (regexp-match re input 0 #f pout)])
(cond
[(not m)
(close-output-port pout)
(values pin;; part
#f;; close-delimiter?
#t;; eof reached?
(values pin ;; part
#f ;; close-delimiter?
#t ;; eof reached?
)]
[(cadr m)
(close-output-port pout)
(values pin #t #f)]
[else
(close-output-port pout)
(values pin #f #f)]))))))
(values pin #f #f)]))))])
;; pre-amble is allowed to be completely empty:
(if (regexp-match-peek (make-re "^") input)
;; No \r\f before first separator:
@ -289,8 +292,7 @@
(let-values ([(part close? eof?) (eat-part)])
(cond (close? (list part))
(eof? (list part))
(else
(cons part (loop))))))))))
(else (cons part (loop))))))))))
;; MIME-message-headers := entity-headers
;; fields
@ -300,7 +302,7 @@
;; ; definition should be ignored.
(define MIME-message-headers
(lambda (headers)
(let ((message (make-default-message)))
(let ([message (make-default-message)])
(entity-headers headers message #t)
message)))
@ -314,7 +316,7 @@
;; ; definition should be ignored.
(define MIME-part-headers
(lambda (headers)
(let ((message (make-default-message)))
(let ([message (make-default-message)])
(entity-headers headers message #f)
message)))
@ -325,12 +327,12 @@
;; *( MIME-extension-field CRLF )
(define entity-headers
(lambda (headers message version?)
(let ((entity (message-entity message)))
(let ([entity (message-entity message)])
(let-values ([(mime non-mime) (get-fields headers)])
(let loop ((fields mime))
(let loop ([fields mime])
(unless (null? fields)
;; Process MIME field
(let ((trimmed-h (trim-comments (car fields))))
(let ([trimmed-h (trim-comments (car fields))])
(or (and version? (version trimmed-h message))
(content trimmed-h entity)
(encoding trimmed-h entity)
@ -340,23 +342,22 @@
(MIME-extension-field trimmed-h entity))
;; keep going
(loop (cdr fields)))))
;; NON-mime headers (or semantically incorrect). In
;; order to make this implementation of rfc2045 robuts,
;; we will save the header in the fields field of the
;; message struct:
;; NON-mime headers (or semantically incorrect). In order to make
;; this implementation of rfc2045 robuts, we will save the header in
;; the fields field of the message struct:
(set-message-fields! message non-mime)
;; Return message
message))))
(define get-fields
(lambda (headers)
(let ((mime null) (non-mime null))
(letrec ((store-field
(let ([mime null] [non-mime null])
(letrec ([store-field
(lambda (f)
(unless (string=? f "")
(if (mime-header? f)
(set! mime (append mime (list (trim-spaces f))))
(set! non-mime (append non-mime (list (trim-spaces f)))))))))
(set! non-mime (append non-mime (list (trim-spaces f)))))))])
(let ([fields (extract-all-fields headers)])
(for-each (lambda (p)
(store-field (format "~a: ~a" (car p) (cdr p))))
@ -371,21 +372,21 @@
(or (regexp-match re:content h)
(regexp-match re:mime h))))
;;; Headers
;;; Content-type follows this BNF syntax:
;; content := "Content-Type" ":" type "/" subtype
;; *(";" parameter)
;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive.
(define re:content-type (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define re:content-type
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define content
(lambda (header entity)
(let* ((params (string-tokenizer #\; header))
(one re:content-type)
(h (trim-all-spaces (car params)))
(target (regexp-match one h))
(old-param (entity-params entity)))
(let* ([params (string-tokenizer #\; header)]
[one re:content-type]
[h (trim-all-spaces (car params))]
[target (regexp-match one h)]
[old-param (entity-params entity)])
(and target
(set-entity-type! entity
(type (regexp-replace one h "\\1"))) ;; type
@ -394,21 +395,21 @@
(set-entity-params!
entity
(append old-param
(let loop ((p (cdr params));; parameters
(ans null))
(cond ((null? p) ans)
(else
(let ((par-pair (parameter (trim-all-spaces (car p)))))
(cond (par-pair
(let loop ([p (cdr params)] ;; parameters
[ans null])
(cond [(null? p) ans]
[else
(let ([par-pair (parameter (trim-all-spaces (car p)))])
(cond [par-pair
(when (string=? (car par-pair) "charset")
(set-entity-charset! entity (cdr par-pair)))
(loop (cdr p)
(append ans
(list par-pair))))
(else
(list par-pair)))]
[else
(warning "Invalid parameter for Content-Type: `~a'" (car p))
;; go on...
(loop (cdr p) ans)))))))))))))
(loop (cdr p) ans)]))]))))))))
;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":"
@ -417,11 +418,11 @@
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
(define dispositione
(lambda (header entity)
(let* ((params (string-tokenizer #\; header))
(reg re:content-disposition)
(h (trim-all-spaces (car params)))
(target (regexp-match reg h))
(disp-struct (entity-disposition entity)))
(let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition]
[h (trim-all-spaces (car params))]
[target (regexp-match reg h)]
[disp-struct (entity-disposition entity)])
(and target
(set-disposition-type!
disp-struct
@ -429,23 +430,25 @@
(disp-params (cdr params) disp-struct)))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define re:mime-version
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define version
(lambda (header message)
(let* ((reg re:mime-version)
(h (trim-all-spaces header))
(target (regexp-match reg h)))
(let* ([reg re:mime-version]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-message-version!
message
(string->number (regexp-replace reg h "\\1.\\2")))))))
;; description := "Content-Description" ":" *text
(define re:content-description (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define re:content-description
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define description
(lambda (header entity)
(let* ((reg re:content-description)
(target (regexp-match reg header)))
(let* ([reg re:content-description]
[target (regexp-match reg header)])
(and target
(set-entity-description!
entity
@ -455,9 +458,9 @@
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
(define encoding
(lambda (header entity)
(let* ((reg re:content-transfer-encoding)
(h (trim-all-spaces header))
(target (regexp-match reg h)))
(let* ([reg re:content-transfer-encoding]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-entity-encoding!
entity
@ -467,9 +470,9 @@
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
(define id
(lambda (header entity)
(let* ((reg re:content-id)
(h (trim-all-spaces header))
(target (regexp-match reg h)))
(let* ([reg re:content-id]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-entity-id!
entity
@ -486,12 +489,11 @@
;; domain-ref = atom ; symbolic reference
(define msg-id
(lambda (str)
(let* ((r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$"))
(ans (regexp-match r str)))
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
[ans (regexp-match r str)])
(if ans
str
(begin (warning "Invalid msg-id: ~a" str)
str)))))
(begin (warning "Invalid msg-id: ~a" str) str)))))
;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" /
@ -500,7 +502,7 @@
(lambda (mech)
(if (not mech)
(raise (make-empty-mechanism))
(let ((val (assoc (lowercase mech) mechanism-alist)))
(let ([val (assoc (lowercase mech) mechanism-alist)])
(or (and val (cdr val))
(ietf-token mech)
(x-token mech))))))
@ -511,8 +513,8 @@
;;
(define MIME-extension-field
(lambda (header entity)
(let* ((reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$"))
(target (regexp-match reg header)))
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
[target (regexp-match reg header)])
(and target
(set-entity-other!
entity
@ -534,20 +536,20 @@
(lambda (value)
(if (not value)
(raise (make-empty-disposition-type))
(let ((val (assoc (lowercase (trim-spaces value)) disposition-alist)))
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(if val (cdr val) (extension-token value))))))
;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token
(define discrete-type
(lambda (value)
(let ((val (assoc (lowercase (trim-spaces value)) discrete-alist)))
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(if val (cdr val) (extension-token value)))))
;; composite-type := "message" / "multipart" / extension-token
(define composite-type
(lambda (value)
(let ((val (assoc (lowercase (trim-spaces value)) composite-alist)))
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(if val (cdr val) (extension-token value)))))
;; extension-token := ietf-token / x-token
@ -561,9 +563,8 @@
;; with IANA.>
(define ietf-token
(lambda (value)
(let ((ans (assoc (lowercase (trim-spaces value)) ietf-extensions)))
(and ans
(cdr ans)))))
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(and ans (cdr ans)))))
;; Directly from RFC 1700:
;; Type Subtype Description Reference
@ -616,14 +617,13 @@
;; video mpeg [RFC1521,NSB]
;; quicktime [Paul Lindner]
;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token>
(define x-token
(lambda (value)
(let* ((r #rx"^[xX]-(.*)")
(h (trim-spaces value))
(ans (regexp-match r h)))
(let* ([r #rx"^[xX]-(.*)"]
[h (trim-spaces value)]
[ans (regexp-match r h)])
(and ans
(token (regexp-replace r h "\\1"))
h))))
@ -641,17 +641,16 @@
;; as specified in RFC 2048.>
(define iana-token
(lambda (value)
(let ((ans (assoc (lowercase (trim-spaces value)) iana-extensions)))
(and ans
(cdr ans)))))
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(and ans (cdr ans)))))
;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)"))
(define parameter
(lambda (par)
(let* ((r re:parameter)
(att (attribute (regexp-replace r par "\\1")))
(val (value (regexp-replace r par "\\2"))))
(let* ([r re:parameter]
[att (attribute (regexp-replace r par "\\1"))]
[val (value (regexp-replace r par "\\2"))])
(if (regexp-match r par)
(cons (if att (lowercase att) "???") val)
(cons "???" par)))))
@ -672,8 +671,8 @@
;; ; to use within parameter values
(define token
(lambda (value)
(let* ((tspecials (regexp "[^][()<>@,;:\\\"/?= ]+"))
(ans (regexp-match tspecials value)))
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
[ans (regexp-match tspecials value)])
(and ans
(string=? value (car ans))
(car ans)))))
@ -686,10 +685,9 @@
(define re:quotes (regexp "\"(.+)\""))
(define quoted-string
(lambda (str)
(let* ((quotes re:quotes)
(ans (regexp-match quotes str)))
(and ans
(regexp-replace quotes str "\\1")))))
(let* ([quotes re:quotes]
[ans (regexp-match quotes str)])
(and ans (regexp-replace quotes str "\\1")))))
;; disposition-parm := filename-parm
;; / creation-date-parm
@ -709,33 +707,33 @@
;; size-parm := "size" "=" 1*DIGIT
(define disp-params
(lambda (lst disp)
(let loop ((lst lst))
(let loop ([lst lst])
(unless (null? lst)
(let* ((p (parameter (trim-all-spaces (car lst))))
(parm (car p))
(value (cdr p)))
(cond ((string=? parm "filename")
(set-disposition-filename! disp value))
((string=? parm "creation-date")
(let* ([p (parameter (trim-all-spaces (car lst)))]
[parm (car p)]
[value (cdr p)])
(cond [(string=? parm "filename")
(set-disposition-filename! disp value)]
[(string=? parm "creation-date")
(set-disposition-creation!
disp
(disp-quoted-data-time value)))
((string=? parm "modification-date")
(disp-quoted-data-time value))]
[(string=? parm "modification-date")
(set-disposition-modification!
disp
(disp-quoted-data-time value)))
((string=? parm "read-date")
(disp-quoted-data-time value))]
[(string=? parm "read-date")
(set-disposition-read!
disp
(disp-quoted-data-time value)))
((string=? parm "size")
(disp-quoted-data-time value))]
[(string=? parm "size")
(set-disposition-size!
disp
(string->number value)))
(else
(string->number value))]
[else
(set-disposition-params!
disp
(append (disposition-params disp) (list p)))))
(append (disposition-params disp) (list p)))])
(loop (cdr lst)))))))
;; date-time = [ day "," ] date time ; dd mm yy

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

@ -40,18 +40,18 @@
;; that has character c
(define string-index
(lambda (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))))))))
(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
(lambda (c s)
(let loop ((s s))
(let loop ([s s])
(if (string=? s "") '()
(let ((i (string-index s c)))
(let ([i (string-index s c)])
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
@ -65,7 +65,7 @@
;; 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 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))]
@ -108,7 +108,7 @@
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments
(lambda (str)
(let* ((positions (regexp-match-positions re: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)))
@ -116,31 +116,33 @@
(define lowercase
(lambda (str)
(let loop ((out "") (rest str) (size (string-length str)))
(cond ((zero? size) out)
(else
(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)))))))
(sub1 size))]))))
(define warning void)
#|
(define warning
void
#;
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(newline (current-error-port))))
|#
(newline (current-error-port)))
)
;; Copies its input `in' to its ouput port if given, it uses
;; current-output-port if out is not provided.
(define cat
(opt-lambda (in (out (current-output-port)))
(let loop ((ln (read-line in)))
(let loop ([ln (read-line in)])
(unless (eof-object? ln)
(fprintf out "~a~n" ln)
(fprintf out "~a\n" ln)
(loop (read-line in))))))
)
;;; mime-util.ss ends here

2
collects/net/nntp-sig.ss
View File

@ -16,5 +16,3 @@
(struct no-group-selected ())
(struct article-not-found (article))
(struct authentication-rejected ()))

166
collects/net/nntp-unit.ss
View File

@ -1,6 +1,5 @@
(module nntp-unit (lib "a-unit.ss")
(require (lib "etc.ss")
"nntp-sig.ss")
(require (lib "etc.ss") "nntp-sig.ss")
(import)
(export nntp^)
@ -54,31 +53,28 @@
(define connect-to-server*
(case-lambda
[(receiver sender) (connect-to-server* receiver sender "unspecified"
"unspecified")]
[(receiver sender)
(connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line)
(let ((communicator (make-communicator sender receiver server-name
port-number)))
(let-values (((code response)
(get-single-line-response communicator)))
(let ([communicator (make-communicator sender receiver server-name
port-number)])
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(201) communicator]
((200)
communicator)
(else
((signal-error make-unexpected-response
[(200 201) communicator]
[else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)))))]))
code response)])))]))
;; connect-to-server :
;; string [x number] -> commnicator
(define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number))
(let-values (((receiver sender)
(tcp-connect server-name port-number)))
(let-values ([(receiver sender)
(tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; close-communicator :
@ -95,16 +91,16 @@
(define disconnect-from-server
(lambda (communicator)
(send-to-server communicator "QUIT")
(let-values (((code response)
(get-single-line-response communicator)))
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
((205)
(close-communicator communicator))
(else
[(205)
(close-communicator communicator)]
[else
((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s"
code response)
code response))))))
code response)]))))
;; authenticate-user :
;; communicator x user-name x password -> ()
@ -122,21 +118,20 @@
code response)
code response))
(send-to-server communicator "AUTHINFO USER ~a" user)
(let-values (((code response)
(get-single-line-response communicator)))
(let-values ([(code response) (get-single-line-response communicator)])
(case code
((281) (void)) ; server doesn't ask for a password
((381)
[(281) (void)] ; server doesn't ask for a password
[(381)
(send-to-server communicator "AUTHINFO PASS ~a" password)
(let-values (((code response)
(get-single-line-response communicator)))
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
((281) (void)) ; done
((502) (reject code response))
(else (unexpected code response)))))
((502) (reject code response))
(else (reject code response)
(unexpected code response))))))
[(281) (void)] ; done
[(502) (reject code response)]
[else (unexpected code response)]))]
[(502) (reject code response)]
[else (reject code response)
(unexpected code response)]))))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
@ -157,10 +152,10 @@
(if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line")
line)
(let ((match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))))
line)))])
(values (string->number (car match))
(cadr match))))))
@ -176,8 +171,8 @@
(define get-single-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(let ([receiver (communicator-receiver communicator)])
(let ([status-line (get-one-line-from-server receiver)])
(parse-status-line status-line)))))
;; get-rest-of-multi-line-response :
@ -185,20 +180,20 @@
(define get-rest-of-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ([receiver (communicator-receiver communicator)])
(let loop ()
(let ((l (get-one-line-from-server receiver)))
(let ([l (get-one-line-from-server receiver)])
(cond
((eof-object? l)
[(eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator))
((string=? l ".")
'())
((string=? l "..")
(cons "." (loop)))
(else
(cons l (loop)))))))))
communicator)]
[(string=? l ".")
'()]
[(string=? l "..")
(cons "." (loop))]
[else
(cons l (loop))]))))))
;; get-multi-line-response :
;; communicator -> number x string x list (string)
@ -208,11 +203,11 @@
(define get-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(let-values (((code rest-of-line)
(parse-status-line status-line)))
(values code rest-of-line (get-rest-of-multi-line-response)))))))
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line)
(parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response))))))
;; open-news-group :
;; communicator x string -> number x number x number
@ -223,32 +218,32 @@
(define open-news-group
(lambda (communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values (((code rest-of-line)
(get-single-line-response communicator)))
(let-values ([(code rest-of-line)
(get-single-line-response communicator)])
(case code
((211)
(let ((match (map string->number
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))))
(let ((number-of-articles (car match))
(first-article-number (cadr match))
(last-article-number (caddr match)))
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number))))
((411)
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name))
(else
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line))))))
code rest-of-line)]))))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
@ -260,26 +255,26 @@
(if (number? message-index)
(number->string message-index)
message-index))
(let-values (((code response)
(get-single-line-response communicator)))
(let-values ([(code response)
(get-single-line-response communicator)])
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code
((423)
[(423)
((signal-error make-article-not-in-group
"article id ~s not in group" message-index)
message-index))
((412)
message-index)]
[(412)
((signal-error make-no-group-selected
"no group selected")))
((430)
"no group selected"))]
[(430)
((signal-error make-article-not-found
"no article id ~s found" message-index)
message-index))
(else
message-index)]
[else
((signal-error make-unexpected-response
"unexpected message access response: ~s" code)
code response))))))))
code response)]))))))
;; head-of-message :
;; communicator x (number U string) -> list (string)
@ -311,12 +306,12 @@
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":"))))
@ -325,13 +320,12 @@
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(let loop ([headers headers])
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(let ([first (car headers)]
[rest (cdr headers)])
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))

4
collects/net/nntp.ss
View File

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

169
collects/net/pop3-unit.ss
View File

@ -1,6 +1,5 @@
(module pop3-unit (lib "a-unit.ss")
(require (lib "etc.ss")
"pop3-sig.ss")
(require (lib "etc.ss") "pop3-sig.ss")
(import)
(export pop3^)
@ -75,22 +74,22 @@
(case-lambda
[(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number)
(let ((communicator (make-communicator sender receiver server-name port-number
'authorization)))
(let ((response (get-status-response/basic communicator)))
(let ([communicator (make-communicator sender receiver server-name port-number
'authorization)])
(let ([response (get-status-response/basic communicator)])
(cond
((+ok? response) communicator)
((-err? response)
[(+ok? response) communicator]
[(-err? response)
((signal-error make-cannot-connect
"cannot connect to ~a on port ~a"
server-name port-number))))))]))
server-name port-number))])))]))
;; connect-to-server :
;; string [x number] -> communicator
(define connect-to-server
(opt-lambda (server-name (port-number default-pop-port-number))
(let-values (((receiver sender) (tcp-connect server-name port-number)))
(let-values ([(receiver sender) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; authenticate/plain-text :
@ -101,22 +100,22 @@
(define authenticate/plain-text
(lambda (username password communicator)
(let ((sender (communicator-sender communicator)))
(let ([sender (communicator-sender communicator)])
(send-to-server communicator "USER ~a" username)
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
(cond
((+ok? status)
[(+ok? status)
(send-to-server communicator "PASS ~a" password)
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
(cond
((+ok? status)
(set-communicator-state! communicator 'transaction))
((-err? status)
[(+ok? status)
(set-communicator-state! communicator 'transaction)]
[(-err? status)
((signal-error make-password-rejected
"password was rejected"))))))
((-err? status)
"password was rejected"))]))]
[(-err? status)
((signal-error make-username-rejected
"username was rejected"))))))))
"username was rejected"))])))))
;; get-mailbox-status :
;; communicator -> number x number
@ -131,11 +130,11 @@
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values (((status result)
(let-values ([(status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)))
#f)])
result)))))
;; get-message/complete :
@ -146,14 +145,14 @@
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
(cond
((+ok? status)
(split-header/body (get-multi-line-response communicator)))
((-err? status)
[(+ok? status)
(split-header/body (get-multi-line-response communicator))]
[(-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message))))))
communicator message)]))))
;; get-message/headers :
;; communicator x number -> list (string)
@ -163,25 +162,24 @@
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
(cond
((+ok? status)
(let-values (((headers body)
[(+ok? status)
(let-values ([(headers body)
(split-header/body
(get-multi-line-response communicator))))
headers))
((-err? status)
(get-multi-line-response communicator))])
headers)]
[(-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message))))))
communicator message)]))))
;; get-message/body :
;; communicator x number -> list (string)
(define get-message/body
(lambda (communicator message)
(let-values (((headers body)
(get-message/complete communicator message)))
(let-values ([(headers body) (get-message/complete communicator message)])
body)))
;; split-header/body :
@ -191,11 +189,11 @@
(define split-header/body
(lambda (lines)
(let loop ((lines lines) (header null))
(let loop ([lines lines] [header null])
(if (null? lines)
(values (reverse header) null)
(let ((first (car lines))
(rest (cdr lines)))
(let ([first (car lines)]
[rest (cdr lines)])
(if (string=? first "")
(values (reverse header) rest)
(loop rest (cons first header))))))))
@ -208,14 +206,14 @@
(confirm-transaction-mode communicator
"cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message)
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
(cond
((-err? status)
[(-err? status)
((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message)
communicator message))
((+ok? status)
'deleted)))))
communicator message)]
[(+ok? status)
'deleted]))))
;; regexp for UIDL responses
@ -228,19 +226,17 @@
(confirm-transaction-mode communicator
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message)
(let-values (((status result)
(get-status-response/match communicator
uidl-regexp
".*")))
(let-values ([(status result)
(get-status-response/match communicator uidl-regexp ".*")])
;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond
((-err? status)
[(-err? status)
((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message)
communicator message))
((+ok? status)
(cadr result)))))
communicator message)]
[(+ok? status)
(cadr result)])))
;; get-unique-id/all :
;; communicator -> list(number x string)
@ -249,14 +245,14 @@
(confirm-transaction-mode communicator
"cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL")
(let ((status (get-status-response/basic communicator)))
(let ([status (get-status-response/basic communicator)])
;; The server response is of the form
;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7
;; .
(map (lambda (l)
(let ((m (regexp-match uidl-regexp l)))
(let ([m (regexp-match uidl-regexp l)])
(cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator))))
@ -275,14 +271,14 @@
(lambda (communicator)
(send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected)
(let ((response (get-status-response/basic communicator)))
(let ([response (get-status-response/basic communicator)])
(close-communicator communicator)
(cond
((+ok? response) (void))
((-err? response)
[(+ok? response) (void)]
[(-err? response)
((signal-error make-disconnect-not-quiet
"got error status upon disconnect")
communicator))))))
communicator)]))))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
@ -311,12 +307,12 @@
(define get-server-status-response
(lambda (communicator)
(let* ((receiver (communicator-receiver communicator))
(status-line (get-one-line-from-server receiver))
(r (regexp-match #rx"^\\+OK(.*)" status-line)))
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]
[r (regexp-match #rx"^\\+OK(.*)" status-line)])
(if r
(values (make-+ok) (cadr r))
(let ((r (regexp-match #rx"^\\-ERR(.*)" status-line)))
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r
(values (make--err) (cadr r))
(signal-malformed-response-error communicator)))))))
@ -329,8 +325,8 @@
(define get-status-response/basic
(lambda (communicator)
(let-values (((response rest)
(get-server-status-response communicator)))
(let-values ([(response rest)
(get-server-status-response communicator)])
response)))
;; get-status-response/match :
@ -341,14 +337,14 @@
(define get-status-response/match
(lambda (communicator +regexp -regexp)
(let-values (((response rest)
(get-server-status-response communicator)))
(let-values ([(response rest)
(get-server-status-response communicator)])
(if (and +regexp (+ok? response))
(let ((r (regexp-match +regexp rest)))
(let ([r (regexp-match +regexp rest)])
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(if (and -regexp (-err? response))
(let ((r (regexp-match -regexp rest)))
(let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator))))))
@ -358,19 +354,19 @@
(define get-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ([receiver (communicator-receiver communicator)])
(let loop ()
(let ((l (get-one-line-from-server receiver)))
(let ([l (get-one-line-from-server receiver)])
(cond
((eof-object? l)
(signal-malformed-response-error communicator))
((string=? l ".")
'())
((and (> (string-length l) 1)
[(eof-object? l)
(signal-malformed-response-error communicator)]
[(string=? l ".")
'()]
[(and (> (string-length l) 1)
(char=? (string-ref l 0) #\.))
(cons (substring l 1 (string-length l)) (loop)))
(else
(cons l (loop)))))))))
(cons (substring l 1 (string-length l)) (loop))]
[else
(cons l (loop))]))))))
;; make-desired-header :
;; string -> desired
@ -384,12 +380,12 @@
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":"))))
@ -398,13 +394,12 @@
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(let loop ([headers headers])
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(let ([first (car headers)]
[rest (cdr headers)])
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))

5
collects/net/pop3.ss
View File

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

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

@ -321,7 +321,7 @@ Tests:
[(< n 0) (fetch-delete! t (- n))]
[(inexact? n) (fetch-shift! t (inexact->exact n))]
[else (fetch-insert! t (list n))])
(printf "Check ~a~n" v)
(printf "Check ~a\n" v)
(let ([v (map list v)])
(unless (equal? (fetch-tree->list t) v)
(error 'bad "~s != ~s" (fetch-tree->list t) v))))

46
collects/net/qp-unit.ss
View File

@ -42,7 +42,7 @@
;; returns the quoted printable representation of STR.
(define qp-encode
(lambda (str)
(let ((out (open-output-bytes)))
(let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out))))
@ -50,53 +50,53 @@
;; returns STR unqp.
(define qp-decode
(lambda (str)
(let ((out (open-output-bytes)))
(let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out))))
(define qp-decode-stream
(lambda (in out)
(let loop ((ch (read-byte in)))
(let loop ([ch (read-byte in)])
(unless (eof-object? ch)
(case ch
((61) ;; A "=", which is quoted-printable stuff
(let ((next (read-byte in)))
[(61) ;; A "=", which is quoted-printable stuff
(let ([next (read-byte in)])
(cond
((eq? next 10)
[(eq? next 10)
;; Soft-newline -- drop it
(void))
((eq? next 13)
(void)]
[(eq? next 13)
;; Expect a newline for a soft CRLF...
(let ((next-next (read-byte in)))
(let ([next-next (read-byte in)])
(if (eq? next-next 10)
;; Good.
(loop (read-byte in))
;; Not a LF? Well, ok.
(loop next-next))))
((hex-digit? next)
(let ((next-next (read-byte in)))
(cond ((eof-object? next-next)
(loop next-next)))]
[(hex-digit? next)
(let ([next-next (read-byte in)])
(cond [(eof-object? next-next)
(warning "Illegal qp sequence: `=~a'" next)
(display "=" out)
(display next out))
((hex-digit? next-next)
(display next out)]
[(hex-digit? next-next)
;; qp-encoded
(write-byte (hex-bytes->byte next next-next)
out))
(else
out)]
[else
(warning "Illegal qp sequence: `=~a~a'" next next-next)
(write-byte 61 out)
(write-byte next out)
(write-byte next-next out)))))
(else
(write-byte next-next out)]))]
[else
;; Warning: invalid
(warning "Illegal qp sequence: `=~a'" next)
(write-byte 61 out)
(write-byte next out)))
(loop (read-byte in))))
(else
(write-byte next out)])
(loop (read-byte in)))]
[else
(write-byte ch out)
(loop (read-byte in))))))))
(loop (read-byte in))])))))
(define warning
(lambda (msg . args)

4
collects/net/qp.ss
View File

@ -26,9 +26,7 @@
;; Commentary:
(module qp mzscheme
(require (lib "unit.ss")
"qp-sig.ss"
"qp-unit.ss")
(require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
(define-values/invoke-unit/infer qp@)

1
collects/net/sendmail-sig.ss
View File

@ -2,4 +2,3 @@
send-mail-message/port
send-mail-message
(struct no-mail-recipients ()))

47
collects/net/sendmail-unit.ss
View File

@ -1,6 +1,5 @@
(module sendmail-unit (lib "a-unit.ss")
(require (lib "process.ss")
"sendmail-sig.ss")
(require (lib "process.ss") "sendmail-sig.ss")
(import)
(export sendmail^)
@ -13,12 +12,12 @@
(define sendmail-program-file
(if (or (eq? (system-type) 'unix)
(eq? (system-type) 'macosx))
(let loop ((paths sendmail-search-path))
(let loop ([paths sendmail-search-path])
(if (null? paths)
(raise (make-exn:fail:unsupported
"unable to find sendmail on this Unix variant"
(current-continuation-marks)))
(let ((p (build-path (car paths) "sendmail")))
(let ([p (build-path (car paths) "sendmail")])
(if (and (file-exists? p)
(memq 'execute (file-or-directory-permissions p)))
p
@ -47,32 +46,32 @@
(raise (make-no-mail-recipients
"no mail recipients were specified"
(current-continuation-marks))))
(let ((return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))))
(let ((reader (car return))
(writer (cadr return))
(pid (caddr return))
(error-reader (cadddr return)))
(let ([return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))])
(let ([reader (car return)]
[writer (cadr return)]
[pid (caddr return)]
[error-reader (cadddr return)])
(close-input-port reader)
(close-input-port error-reader)
(fprintf writer "From: ~a~n" sender)
(letrec ((write-recipient-header
(fprintf writer "From: ~a\n" sender)
(letrec ([write-recipient-header
(lambda (header-string recipients)
(let ((header-space
(+ (string-length header-string) 2)))
(let ([header-space
(+ (string-length header-string) 2)])
(fprintf writer "~a: " header-string)
(let loop ((to recipients) (indent header-space))
(let loop ([to recipients] [indent header-space])
(if (null? to)
(newline writer)
(let ((first (car to))
(let ([first (car to)]
[rest (cdr to)])
(let ((len (string-length first)))
(let ([len (string-length first)])
(if (>= (+ len indent) 80)
(begin
(fprintf writer
(if (null? rest)
"~n ~a"
"~n ~a, ")
"\n ~a"
"\n ~a, ")
first)
(loop (cdr to)
(+ len header-space 2)))
@ -83,12 +82,12 @@
"~a, ")
first)
(loop (cdr to)
(+ len indent 2))))))))))))
(+ len indent 2))))))))))])
(write-recipient-header "To" to-recipients)
(unless (null? cc-recipients)
(write-recipient-header "CC" cc-recipients)))
(fprintf writer "Subject: ~a~n" subject)
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org~n")
(fprintf writer "Subject: ~a\n" subject)
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
(for-each (lambda (s)
(display s writer)
(newline writer))
@ -109,9 +108,9 @@
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ((writer (apply send-mail-message/port sender subject
(let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
other-headers)))
other-headers)])
(for-each (lambda (s)
(display s writer) ; We use -i, so "." is not a problem
(newline writer))

4
collects/net/sendmail.ss
View File

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

1
collects/net/smtp-sig.ss
View File

@ -3,4 +3,3 @@
smtp-send-message
smtp-send-message*
smtp-sending-end-of-message)

26
collects/net/smtp-unit.ss
View File

@ -1,7 +1,5 @@
(module smtp-unit (lib "a-unit.ss")
(require (lib "kw.ss")
"base64.ss"
"smtp-sig.ss")
(require (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import)
(export smtp^)
@ -22,10 +20,8 @@
(define (check-reply r v w)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio?
'linefeed
'return-linefeed))])
(log "server: ~a~n" l)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l)
(if (eof-object? l)
(error 'check-reply "got EOF")
(let ([n (number->string v)])
@ -64,12 +60,12 @@
(close-output-port w)
(raise x))])
(check-reply r 220 w)
(log "hello~n")
(log "hello\n")
(fprintf w "EHLO ~a~a" (smtp-sending-server) crlf)
(check-reply r 250 w)
(when auth-user
(log "auth~n")
(log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
@ -77,36 +73,36 @@
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from~n")
(log "from\n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w)
(log "to~n")
(log "to\n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf)
(check-reply r 250 w))
recipients)
(log "header~n")
(log "header\n")
(fprintf w "DATA~a" crlf)
(check-reply r 354 w)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a~n" l)
(log "body: ~a\n" l)
(fprintf w "~a~a" (protect-line l) crlf))
message-lines)
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
(log "dot~n")
(log "dot\n")
(fprintf w ".~a" crlf)
(flush-output w)
(check-reply r 250 w)
(log "quit~n")
(log "quit\n")
(fprintf w "QUIT~a" crlf)
(check-reply r 221 w)

4
collects/net/smtp.ss
View File

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

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

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

3
collects/net/unihead.ss
View File

@ -91,7 +91,8 @@
[(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding) "UTF-8")])
(bytes->string/latin-1 encoding)
"UTF-8")])
(if c
(let-values ([(r got status)
(bytes-convert c s)])

4
collects/net/uri-codec.ss
View File

@ -1,7 +1,5 @@
(module uri-codec mzscheme
(require (lib "unit.ss")
"uri-codec-sig.ss"
"uri-codec-unit.ss")
(require (lib "unit.ss") "uri-codec-sig.ss" "uri-codec-unit.ss")
(provide-signature-elements uri-codec^)

1
collects/net/url-sig.ss
View File

@ -12,4 +12,3 @@
combine-url/relative
url-exception?
current-proxy-servers)

3
collects/net/url-unit.ss
View File

@ -291,8 +291,7 @@
;; with paths segments "." and ".." at the end
;; into "./" and "../" respectively
(define (remove-dot-segments path)
(let loop ([path path]
[result '()])
(let loop ([path path] [result '()])
(cond
[(null? path) (reverse result)]
[(and (eq? (path/param-path (car path)) 'same)