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-decode-stream
base64-encode base64-encode
base64-decode) base64-decode)

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

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

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

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

4
collects/net/cgi.ss
View File

@ -1,7 +1,5 @@
(module cgi mzscheme (module cgi mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "cgi-sig.ss" "cgi-unit.ss")
"cgi-sig.ss"
"cgi-unit.ss")
(define-values/invoke-unit/infer cgi@) (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") (module cookie-sig (lib "a-signature.ss")
set-cookie set-cookie
cookie:add-comment cookie:add-comment
cookie:add-domain cookie:add-domain

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

4
collects/net/cookie.ss
View File

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

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

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

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

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

4
collects/net/dns.ss
View File

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

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

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

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

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

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

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

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

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

4
collects/net/head.ss
View File

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

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

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

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

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

5
collects/net/imap.ss
View File

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

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

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

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

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

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

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

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

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

4
collects/net/nntp.ss
View File

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

5
collects/net/pop3.ss
View File

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

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

@ -321,7 +321,7 @@ Tests:
[(< n 0) (fetch-delete! t (- n))] [(< n 0) (fetch-delete! t (- n))]
[(inexact? n) (fetch-shift! t (inexact->exact n))] [(inexact? n) (fetch-shift! t (inexact->exact n))]
[else (fetch-insert! t (list n))]) [else (fetch-insert! t (list n))])
(printf "Check ~a~n" v) (printf "Check ~a\n" v)
(let ([v (map list v)]) (let ([v (map list v)])
(unless (equal? (fetch-tree->list t) v) (unless (equal? (fetch-tree->list t) v)
(error 'bad "~s != ~s" (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. ;; returns the quoted printable representation of STR.
(define qp-encode (define qp-encode
(lambda (str) (lambda (str)
(let ((out (open-output-bytes))) (let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n") (qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out)))) (get-output-bytes out))))
@ -50,53 +50,53 @@
;; returns STR unqp. ;; returns STR unqp.
(define qp-decode (define qp-decode
(lambda (str) (lambda (str)
(let ((out (open-output-bytes))) (let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out) (qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out)))) (get-output-bytes out))))
(define qp-decode-stream (define qp-decode-stream
(lambda (in out) (lambda (in out)
(let loop ((ch (read-byte in))) (let loop ([ch (read-byte in)])
(unless (eof-object? ch) (unless (eof-object? ch)
(case ch (case ch
((61) ;; A "=", which is quoted-printable stuff [(61) ;; A "=", which is quoted-printable stuff
(let ((next (read-byte in))) (let ([next (read-byte in)])
(cond (cond
((eq? next 10) [(eq? next 10)
;; Soft-newline -- drop it ;; Soft-newline -- drop it
(void)) (void)]
((eq? next 13) [(eq? next 13)
;; Expect a newline for a soft CRLF... ;; Expect a newline for a soft CRLF...
(let ((next-next (read-byte in))) (let ([next-next (read-byte in)])
(if (eq? next-next 10) (if (eq? next-next 10)
;; Good. ;; Good.
(loop (read-byte in)) (loop (read-byte in))
;; Not a LF? Well, ok. ;; Not a LF? Well, ok.
(loop next-next)))) (loop next-next)))]
((hex-digit? next) [(hex-digit? next)
(let ((next-next (read-byte in))) (let ([next-next (read-byte in)])
(cond ((eof-object? next-next) (cond [(eof-object? next-next)
(warning "Illegal qp sequence: `=~a'" next) (warning "Illegal qp sequence: `=~a'" next)
(display "=" out) (display "=" out)
(display next out)) (display next out)]
((hex-digit? next-next) [(hex-digit? next-next)
;; qp-encoded ;; qp-encoded
(write-byte (hex-bytes->byte next next-next) (write-byte (hex-bytes->byte next next-next)
out)) out)]
(else [else
(warning "Illegal qp sequence: `=~a~a'" next next-next) (warning "Illegal qp sequence: `=~a~a'" next next-next)
(write-byte 61 out) (write-byte 61 out)
(write-byte next out) (write-byte next out)
(write-byte next-next out))))) (write-byte next-next out)]))]
(else [else
;; Warning: invalid ;; Warning: invalid
(warning "Illegal qp sequence: `=~a'" next) (warning "Illegal qp sequence: `=~a'" next)
(write-byte 61 out) (write-byte 61 out)
(write-byte next out))) (write-byte next out)])
(loop (read-byte in)))) (loop (read-byte in)))]
(else [else
(write-byte ch out) (write-byte ch out)
(loop (read-byte in)))))))) (loop (read-byte in))])))))
(define warning (define warning
(lambda (msg . args) (lambda (msg . args)

4
collects/net/qp.ss
View File

@ -26,9 +26,7 @@
;; Commentary: ;; Commentary:
(module qp mzscheme (module qp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
"qp-sig.ss"
"qp-unit.ss")
(define-values/invoke-unit/infer qp@) (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/port
send-mail-message send-mail-message
(struct no-mail-recipients ())) (struct no-mail-recipients ()))

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

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

4
collects/net/sendmail.ss
View File

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

4
collects/net/smtp.ss
View File

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

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

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

3
collects/net/unihead.ss
View File

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

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

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

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

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

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

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