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)

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

@ -4,137 +4,131 @@
(import) (import)
(export base64^) (export base64^)
(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))))] [(<= (char->integer #\0) n (char->integer #\9))
[(<= (char->integer #\0) n (char->integer #\9)) (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))]
(vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] [(= (char->integer #\+) n)
[(= (char->integer #\+) n) (vector-set! base64-digit n 62)]
(vector-set! base64-digit n 62)] [(= (char->integer #\/) n)
[(= (char->integer #\/) n) (vector-set! base64-digit n 63)]
(vector-set! base64-digit n 63)] [else
[else (vector-set! base64-digit n #f)])
(vector-set! base64-digit n #f)]) (loop (add1 n))))
(loop (add1 n))))
(define digit-base64 (make-vector 64)) (define digit-base64 (make-vector 64))
(define (each-char s e pos) (define (each-char s e pos)
(let loop ([i (char->integer s)][pos pos]) (let loop ([i (char->integer s)][pos pos])
(unless (> i (char->integer e)) (unless (> i (char->integer e))
(vector-set! digit-base64 pos i) (vector-set! digit-base64 pos i)
(loop (add1 i) (add1 pos))))) (loop (add1 i) (add1 pos)))))
(each-char #\A #\Z 0) (each-char #\A #\Z 0)
(each-char #\a #\z 26) (each-char #\a #\z 26)
(each-char #\0 #\9 52) (each-char #\0 #\9 52)
(each-char #\+ #\+ 62) (each-char #\+ #\+ 62)
(each-char #\/ #\/ 63) (each-char #\/ #\/ 63)
(define (base64-filename-safe) (define (base64-filename-safe)
(vector-set! base64-digit (char->integer #\-) 62) (vector-set! base64-digit (char->integer #\-) 62)
(vector-set! base64-digit (char->integer #\_) 63) (vector-set! base64-digit (char->integer #\_) 63)
(each-char #\- #\- 62) (each-char #\- #\- 62)
(each-char #\_ #\_ 63)) (each-char #\_ #\_ 63))
(define (base64-decode-stream in out) (define (base64-decode-stream in out)
(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 [v (loop (+ (arithmetic-shift waiting 6) v)
(cond (+ waiting-bits 6))]
[v (loop (+ (arithmetic-shift waiting 6) v) [(eq? c (char->integer #\=)) (void)] ; done
(+ waiting-bits 6))] [else (loop waiting waiting-bits)])))))
[(eq? c (char->integer #\=)) (void)] ; done
[else (loop waiting waiting-bits)])))))
(define base64-encode-stream
(case-lambda
[(in out) (base64-encode-stream in out #"\n")]
[(in out linesep)
;; Process input 3 characters at a time, because 18 bits
;; is divisible by both 6 and 8, and 72 (the line length)
;; is divisible by 3.
(let ([three (make-bytes 3)]
[outc (lambda (n)
(write-byte (vector-ref digit-base64 n) out))]
[done (lambda (fill)
(let loop ([fill fill])
(unless (zero? fill)
(write-byte (char->integer #\=) out)
(loop (sub1 fill))))
(display linesep out))])
(let loop ([pos 0])
(if (= pos 72)
;; Insert newline
(begin
(display linesep out)
(loop 0))
;; Next group of 3
(let ([n (read-bytes-avail! three in)])
(cond
[(eof-object? n)
(unless (= pos 0) (done 0))]
[(= n 3)
;; Easy case:
(let ([a (bytes-ref three 0)]
[b (bytes-ref three 1)]
[c (bytes-ref three 2)])
(outc (arithmetic-shift a -2))
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4)))
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6)))
(outc (bitwise-and #x3f c))
(loop (+ pos 4)))]
[else
;; Hard case: n is 1 or 2
(let ([a (bytes-ref three 0)])
(outc (arithmetic-shift a -2))
(let* ([next (if (= n 2)
(bytes-ref three 1)
(read-byte in))]
[b (if (eof-object? next)
0
next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4)))
(if (eof-object? next)
(done 2)
;; More to go
(let* ([next (read-byte in)]
[c (if (eof-object? next)
0
next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6)))
(if (eof-object? next)
(done 1)
;; Finish c, loop
(begin
(outc (bitwise-and #x3f c))
(loop (+ pos 4))))))))])))))]))
(define base64-encode-stream (define (base64-decode src)
(case-lambda (let ([s (open-output-bytes)])
[(in out) (base64-encode-stream in out #"\n")] (base64-decode-stream (open-input-bytes src) s)
[(in out linesep) (get-output-bytes s)))
;; Process input 3 characters at a time, because 18 bits
;; is divisible by both 6 and 8, and 72 (the line length)
;; is divisible by 3.
(let ([three (make-bytes 3)]
[outc (lambda (n)
(write-byte (vector-ref digit-base64 n) out))]
[done (lambda (fill)
(let loop ([fill fill])
(unless (zero? fill)
(write-byte (char->integer #\=) out)
(loop (sub1 fill))))
(display linesep out))])
(let loop ([pos 0])
(if (= pos 72)
; Insert newline
(begin
(display linesep out)
(loop 0))
;; Next group of 3
(let ([n (read-bytes-avail! three in)])
(cond
[(eof-object? n)
(unless (= pos 0)
(done 0))]
[(= n 3)
;; Easy case:
(let ([a (bytes-ref three 0)]
[b (bytes-ref three 1)]
[c (bytes-ref three 2)])
(outc (arithmetic-shift a -2))
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4)))
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6)))
(outc (bitwise-and #x3f c))
(loop (+ pos 4)))]
[else
;; Hard case: n is 1 or 2
(let ([a (bytes-ref three 0)])
(outc (arithmetic-shift a -2))
(let* ([next (if (= n 2)
(bytes-ref three 1)
(read-byte in))]
[b (if (eof-object? next)
0
next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4)))
(if (eof-object? next)
(done 2)
;; More to go
(let* ([next (read-byte in)]
[c (if (eof-object? next)
0
next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6)))
(if (eof-object? next)
(done 1)
;; Finish c, loop
(begin
(outc (bitwise-and #x3f c))
(loop (+ pos 4))))))))])))))]))
(define (base64-decode src) (define (base64-encode src)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-decode-stream (open-input-bytes src) s) (base64-encode-stream (open-input-bytes src) s (bytes 13 10))
(get-output-bytes s))) (get-output-bytes s))))
(define (base64-encode src)
(let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s
(bytes 13 10))
(get-output-bytes s))))

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

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

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

@ -5,238 +5,235 @@
(import) (import)
(export cgi^) (export cgi^)
;; type bindings = list ((symbol . string)) ;; type bindings = list ((symbol . string))
;; -------------------------------------------------------------------- ;; --------------------------------------------------------------------
;; Exceptions: ;; Exceptions:
(define-struct cgi-error ()) (define-struct cgi-error ())
;; chars : list (char) ;; chars : list (char)
;; -- gives the suffix which is invalid, not including the `%' ;; -- gives the suffix which is invalid, not including the `%'
(define-struct (incomplete-%-suffix cgi-error) (chars)) (define-struct (incomplete-%-suffix cgi-error) (chars))
;; char : char ;; char : char
;; -- an invalid character in a hex string ;; -- an invalid character in a hex string
(define-struct (invalid-%-suffix cgi-error) (char)) (define-struct (invalid-%-suffix cgi-error) (char))
;; -------------------------------------------------------------------- ;; --------------------------------------------------------------------
;; query-chars->string : list (char) -> string ;; query-chars->string : list (char) -> string
;; -- 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
(let loop ([chars chars]) (let loop ([chars chars])
(if (null? chars) null (if (null? chars) null
(let ([first (car chars)] (let ([first (car chars)]
[rest (cdr chars)]) [rest (cdr chars)])
(let-values ([(this rest) (let-values ([(this rest)
(cond (cond
[(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 (car rest) (cadr rest))
(string 16)
(car rest) (cadr rest)) (raise (make-invalid-%-suffix
16) (if (string->number
(raise (make-invalid-%-suffix (string (car rest))
(if (string->number 16)
(string (car rest)) (cadr rest)
16) (car rest))))))
(cadr rest) (cddr rest))
(car rest)))))) (raise (make-incomplete-%-suffix rest)))]
(cddr rest)) [else
(raise (values first rest)])])
(make-incomplete-%-suffix rest)))] (cons this (loop rest))))))))
[else
(values first rest)])])
(cons this (loop rest))))))))
;; string->html : string -> string ;; string->html : string -> string
;; -- 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
(case c (map (lambda (c)
[(#\<) "&lt;"] (case c
[(#\>) "&gt;"] [(#\<) "&lt;"]
[(#\&) "&amp;"] [(#\>) "&gt;"]
[else (string c)])) [(#\&) "&amp;"]
(string->list s)))) [else (string c)]))
(string->list s))))
(define default-text-color "#000000") (define default-text-color "#000000")
(define default-bg-color "#ffffff") (define default-bg-color "#ffffff")
(define default-link-color "#cc2200") (define default-link-color "#cc2200")
(define default-vlink-color "#882200") (define default-vlink-color "#882200")
(define default-alink-color "#444444") (define default-alink-color "#444444")
;; generate-html-output : ;; generate-html-output :
;; html-string x list (html-string) x ... -> () ;; html-string x list (html-string) x ... -> ()
(define generate-html-output (define generate-html-output
(opt-lambda (title body-lines (opt-lambda (title body-lines
[text-color default-text-color] [text-color default-text-color]
[bg-color default-bg-color] [bg-color default-bg-color]
[link-color default-link-color] [link-color default-link-color]
[vlink-color default-vlink-color] [vlink-color default-vlink-color]
[alink-color default-alink-color]) [alink-color default-alink-color])
(let ([sa string-append]) (let ([sa string-append])
(for-each (for-each
(lambda (l) (display l) (newline)) (lambda (l) (display l) (newline))
`("Content-type: text/html" `("Content-type: text/html"
"" ""
"<html>" "<html>"
"<!-- The form was processed, and this document was generated," "<!-- The form was processed, and this document was generated,"
" using the CGI utilities for MzScheme. For more information" " using the CGI utilities for MzScheme. For more information"
" on MzScheme, see" " on MzScheme, see"
" http://www.plt-scheme.org/software/mzscheme/" " http://www.plt-scheme.org/software/mzscheme/"
" and for the CGI utilities, contact" " and for the CGI utilities, contact"
" (sk@cs.brown.edu). -->" " (sk@cs.brown.edu). -->"
"<head>" "<head>"
,(sa "<title>" title "</title>") ,(sa "<title>" title "</title>")
"</head>" "</head>"
"" ""
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"") ,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
,(sa " link=\"" link-color "\"") ,(sa " link=\"" link-color "\"")
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">") ,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
"" ""
,@body-lines ,@body-lines
"" ""
"</body>" "</body>"
"</html>"))))) "</html>")))))
;; output-http-headers : -> void ;; output-http-headers : -> void
(define (output-http-headers) (define (output-http-headers)
(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)])
(cond [(eof-object? c) (values (reverse chars) #t)] (cond [(eof-object? c) (values (reverse chars) #t)]
[(char=? c delimiter) (values (reverse chars) #f)] [(char=? c delimiter) (values (reverse chars) #f)]
[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)]
[eof? [eof?
(generate-error-output (generate-error-output
(list "Server generated malformed input for POST method:" (list "Server generated malformed input for POST method:"
(string-append (string-append
"No binding for `" (list->string name) "' field.")))] "No binding for `" (list->string name) "' field.")))]
[else (let-values ([(value eof?) (read-until-char ip #\&)]) [else (let-values ([(value eof?) (read-until-char ip #\&)])
(values (string->symbol (query-chars->string name)) (values (string->symbol (query-chars->string name))
(query-chars->string value) (query-chars->string value)
eof?))]))) eof?))])))
;; get-bindings/post : () -> bindings ;; get-bindings/post : () -> bindings
(define (get-bindings/post) (define (get-bindings/post)
(let-values ([(name value eof?) (read-name+value (current-input-port))]) (let-values ([(name value eof?) (read-name+value (current-input-port))])
(cond [(and eof? (not name)) null]
[(and eof? name) (list (cons name value))]
[else (cons (cons name value) (get-bindings/post))])))
;; get-bindings/get : () -> bindings
(define (get-bindings/get)
(let ([p (open-input-string (getenv "QUERY_STRING"))])
(let loop ()
(let-values ([(name value eof?) (read-name+value p)])
(cond [(and eof? (not name)) null] (cond [(and eof? (not name)) null]
[(and eof? name) (list (cons name value))] [(and eof? name) (list (cons name value))]
[else (cons (cons name value) (get-bindings/post))]))) [else (cons (cons name value) (loop))])))))
;; get-bindings/get : () -> bindings ;; get-bindings : () -> bindings
(define (get-bindings/get) (define (get-bindings)
(let ([p (open-input-string (getenv "QUERY_STRING"))]) (if (string=? (get-cgi-method) "POST")
(let loop () (get-bindings/post)
(let-values ([(name value eof?) (read-name+value p)]) (get-bindings/get)))
(cond [(and eof? (not name)) null]
[(and eof? name) (list (cons name value))]
[else (cons (cons name value) (loop))])))))
;; get-bindings : () -> bindings ;; generate-error-output : list (html-string) -> <exit>
(define (get-bindings) (define (generate-error-output error-message-lines)
(if (string=? (get-cgi-method) "POST") (generate-html-output "Internal Error" error-message-lines)
(get-bindings/post) (exit))
(get-bindings/get)))
;; generate-error-output : list (html-string) -> <exit> ;; bindings-as-html : bindings -> list (html-string)
(define (generate-error-output error-message-lines) ;; -- formats name-value bindings as HTML appropriate for displaying
(generate-html-output "Internal Error" error-message-lines) (define (bindings-as-html bindings)
(exit)) `("<code>"
,@(map (lambda (bind)
(string-append (symbol->string (car bind))
"&nbsp;--&gt;&nbsp;"
(cdr bind)
"<br>"))
bindings)
"</code>"))
;; bindings-as-html : bindings -> list (html-string) ;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- formats name-value bindings as HTML appropriate for displaying ;; -- Extracts the bindings associated with a given name. The semantics of
(define (bindings-as-html bindings) ;; forms states that a CHECKBOX may use the same NAME field multiple times.
`("<code>" ;; Hence, a list of strings is returned. Note that the result may be the
,@(map (lambda (bind) ;; empty list.
(string-append (symbol->string (car bind)) (define (extract-bindings field-name bindings)
"&nbsp;--&gt;&nbsp;" (let ([field-name (if (symbol? field-name)
(cdr bind) field-name (string->symbol field-name))])
"<br>")) (let loop ([found null] [bindings bindings])
bindings) (if (null? bindings)
"</code>")) found
(if (equal? field-name (caar bindings))
(loop (cons (cdar bindings) found) (cdr bindings))
(loop found (cdr bindings)))))))
;; extract-bindings : (string + symbol) x bindings -> list (string) ;; extract-binding/single : (string + symbol) x bindings -> string
;; -- Extracts the bindings associated with a given name. The semantics ;; -- used in cases where only one binding is supposed to occur
;; of forms states that a CHECKBOX may use the same NAME field multiple (define (extract-binding/single field-name bindings)
;; times. Hence, a list of strings is returned. Note that the result (let* ([field-name (if (symbol? field-name)
;; may be the empty list. field-name (string->symbol field-name))]
(define (extract-bindings field-name bindings) [result (extract-bindings field-name bindings)])
(let ([field-name (if (symbol? field-name) (cond
field-name (string->symbol field-name))]) [(null? result)
(let loop ([found null] [bindings bindings]) (generate-error-output
(if (null? bindings) (cons (format "No binding for field `~a':<br>" field-name)
found (bindings-as-html bindings)))]
(if (equal? field-name (caar bindings)) [(null? (cdr result))
(loop (cons (cdar bindings) found) (cdr bindings)) (car result)]
(loop found (cdr bindings))))))) [else
(generate-error-output
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
field-name)
(bindings-as-html bindings)))])))
;; extract-binding/single : (string + symbol) x bindings -> string ;; get-cgi-method : () -> string
;; -- used in cases where only one binding is supposed to occur ;; -- string is either GET or POST (though future extension is possible)
(define (extract-binding/single field-name bindings) (define (get-cgi-method)
(let* ([field-name (if (symbol? field-name) (getenv "REQUEST_METHOD"))
field-name (string->symbol field-name))]
[result (extract-bindings field-name bindings)])
(cond
[(null? result)
(generate-error-output
(cons (format "No binding for field `~a':<br>" field-name)
(bindings-as-html bindings)))]
[(null? (cdr result))
(car result)]
[else
(generate-error-output
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
field-name)
(bindings-as-html bindings)))])))
;; get-cgi-method : () -> string ;; generate-link-text : string x html-string -> html-string
;; -- string is either GET or POST (though future extension is possible) (define (generate-link-text url anchor-text)
(define (get-cgi-method) (string-append "<a href=\"" url "\">" anchor-text "</a>"))
(getenv "REQUEST_METHOD"))
;; generate-link-text : string x html-string -> html-string
(define (generate-link-text url anchor-text)
(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

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

@ -49,9 +49,9 @@
(module cookie-unit (lib "a-unit.ss") (module cookie-unit (lib "a-unit.ss")
(require (lib "etc.ss") (require (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss" "srfi" "13") (lib "string.ss" "srfi" "13")
(lib "char-set.ss" "srfi" "14") (lib "char-set.ss" "srfi" "14")
"cookie-sig.ss") "cookie-sig.ss")
(import) (import)
@ -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
@ -67,24 +75,23 @@
;; NAME = attr ;; NAME = attr
;; VALUE = value ;; VALUE = value
;; cookie-av = "Comment" "=" value ;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value ;; | "Domain" "=" value
;; | "Max-Age" "=" value ;; | "Max-Age" "=" value
;; | "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) (cookie-error "Invalid cookie name: ~a / ~a" name value))
(raise (build-cookie-error (format "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) (cookie-error "Cookie expected, received: ~a" cookie))
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) (string-join
(string-join (filter (lambda (s) (not (string-null? s)))
(filter (lambda (s) (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(not (string-null? s))) (let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie)) (let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
(let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) "")) (let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
(let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) "")) (let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
(let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) "")) (let ([s (cookie-secure cookie)]) (if s "Secure" ""))
(let ((p (cookie-path cookie))) (if p (format "Path=~a" p) "")) (let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
(let ((s (cookie-secure cookie))) (if s "Secure" "")) "; "))
(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)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-comment! cookie comment)
cookie)))
(define cookie:add-domain
(lambda (cookie domain)
(unless (valid-domain? domain)
(raise (build-cookie-error (format "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-comment! cookie comment)
cookie)) cookie))
(define cookie:add-max-age (define (cookie:add-domain cookie domain)
(lambda (cookie seconds) (unless (valid-domain? domain)
(unless (and (integer? seconds) (not (negative? seconds))) (cookie-error "Invalid domain: ~a" domain))
(raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds)))) (unless (cookie? cookie)
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-domain! cookie domain)
cookie)
(define (cookie:add-max-age cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(cookie-error "Invalid Max-Age for cookie: ~a" seconds))
(unless (cookie? cookie)
(cookie-error "Cookie expected, received: ~a" cookie))
(set-cookie-max-age! cookie seconds)
cookie)
(define (cookie:add-path cookie 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-max-age! cookie seconds) (set-cookie-path! cookie path)
cookie)) cookie))
(define cookie:add-path (define (cookie:secure cookie secure?)
(lambda (cookie pre-path) (unless (boolean? secure?)
(let ([path (to-rfc2109:value pre-path)]) (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-path! cookie path) (set-cookie-secure! cookie secure?)
cookie))) cookie)
(define cookie:secure (define (cookie:version cookie version)
(lambda (cookie secure?) (unless (integer? version)
(unless (boolean? secure?) (cookie-error "Unsupported version: ~a" version))
(raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?)))) (unless (cookie? cookie)
(unless (cookie? cookie) (cookie-error "Cookie expected, received: ~a" cookie))
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) (set-cookie-version! cookie version)
(set-cookie-secure! cookie secure?) cookie)
cookie))
(define cookie:version
(lambda (cookie version)
(unless (integer? version)
(raise (build-cookie-error (format "Unsupported version: ~a" version))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-version! cookie version)
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)))))
;;;;; ;;;;;
@ -221,9 +217,9 @@
;; token = 1*<any CHAR except CTLs or tspecials> ;; token = 1*<any CHAR except CTLs or tspecials>
;; ;;
;; tspecials = "(" | ")" | "<" | ">" | "@" ;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <"> ;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "=" ;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT ;; | "{" | "}" | SP | HT
(define char-set:tspecials (define char-set:tspecials
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}") (char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
char-set:whitespace char-set:whitespace
@ -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)
#f))) s
#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 (string=? (string-take dom 1) ".")
;; Domain must start with a dot (.) ;; The rest are tokens-like strings separated by dots
(string=? (string-take dom 1) ".") (string-every char-set:hostname dom)
;; The rest are tokens-like strings separated by dots (<= (string-length dom) 76)))
(string-every char-set:hostname dom)
(<= (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)

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

@ -1,342 +1,321 @@
(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^)
;; UDP retry timeout: ;; UDP retry timeout:
(define INIT-TIMEOUT 50) (define INIT-TIMEOUT 50)
(define types (define types
'((a 1) '((a 1)
(ns 2) (ns 2)
(md 3) (md 3)
(mf 4) (mf 4)
(cname 5) (cname 5)
(soa 6) (soa 6)
(mb 7) (mb 7)
(mg 8) (mg 8)
(mr 9) (mr 9)
(null 10) (null 10)
(wks 11) (wks 11)
(ptr 12) (ptr 12)
(hinfo 13) (hinfo 13)
(minfo 14) (minfo 14)
(mx 15) (mx 15)
(txt 16))) (txt 16)))
(define classes (define classes
'((in 1) '((in 1)
(cs 2) (cs 2)
(ch 3) (ch 3)
(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) [else (cossa i (cdr l))]))
(car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (number->octet-pair n) (define (octet-pair->number a b)
(list (arithmetic-shift n -8) (+ (arithmetic-shift a 8) b))
(modulo n 256)))
(define (octet-pair->number a b) (define (octet-quad->number a b c d)
(+ (arithmetic-shift a 8) (+ (arithmetic-shift a 24)
b)) (arithmetic-shift b 16)
(arithmetic-shift c 8)
d))
(define (octet-quad->number a b c d) (define (name->octets s)
(+ (arithmetic-shift a 24) (let ([do-one (lambda (s)
(arithmetic-shift b 16) (cons (bytes-length s) (bytes->list s)))])
(arithmetic-shift c 8) (let loop ([s s])
d)) (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m
(append (do-one (cadr m)) (loop (caddr m)))
(append (do-one s) (list 0)))))))
(define (name->octets s) (define (make-std-query-header id question-count)
(let ([do-one (lambda (s) (append (number->octet-pair id)
(cons (list 1 0) ; Opcode & flags (recusive flag set)
(bytes-length s) (number->octet-pair question-count)
(bytes->list s)))]) (number->octet-pair 0)
(let loop ([s s]) (number->octet-pair 0)
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) (number->octet-pair 0)))
(if m
(append
(do-one (cadr m))
(loop (caddr m)))
(append
(do-one s)
(list 0)))))))
(define (make-std-query-header id question-count) (define (make-query id name type class)
(append (append (make-std-query-header id 1)
(number->octet-pair id) (name->octets name)
(list 1 0) ; Opcode & flags (recusive flag set) (number->octet-pair (cadr (assoc type types)))
(number->octet-pair question-count) (number->octet-pair (cadr (assoc class classes)))))
(number->octet-pair 0)
(number->octet-pair 0)
(number->octet-pair 0)))
(define (make-query id name type class) (define (add-size-tag m)
(append (append (number->octet-pair (length m)) m))
(make-std-query-header id 1)
(name->octets name)
(number->octet-pair (cadr (assoc type types)))
(number->octet-pair (cadr (assoc class classes)))))
(define (add-size-tag m) (define (rr-data rr)
(append (number->octet-pair (length m)) m)) (cadddr (cdr rr)))
(define (rr-data rr) (define (rr-type rr)
(cadddr (cdr rr))) (cadr rr))
(define (rr-type rr) (define (rr-name rr)
(cadr rr)) (car rr))
(define (rr-name rr) (define (parse-name start reply)
(car rr)) (let ([v (car start)])
(cond
[(zero? v)
;; End of name
(values #f (cdr start))]
[(zero? (bitwise-and #xc0 v))
;; Normal label
(let loop ([len v][start (cdr start)][accum null])
(cond
[(zero? len)
(let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse! accum))])
(values (if s (bytes-append s0 #"." s) s0)
start)))]
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
[else
;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(cadr start))])
(let-values ([(s ignore-start)
(parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-name start reply) (define (parse-rr start reply)
(let ([v (car start)]) (let-values ([(name start) (parse-name start reply)])
(cond (let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
[(zero? v) types))]
;; End of name [start (cddr start)]
(values #f (cdr start))] ;;
[(zero? (bitwise-and #xc0 v)) [class (car (cossa (octet-pair->number (car start) (cadr start))
;; Normal label classes))]
(let loop ([len v][start (cdr start)][accum null]) [start (cddr start)]
(cond ;;
[(zero? len) [ttl (octet-quad->number (car start) (cadr start)
(let-values ([(s start) (parse-name start reply)]) (caddr start) (cadddr start))]
(let ([s0 (list->bytes (reverse! accum))]) [start (cddddr start)]
(values (if s ;;
(bytes-append s0 #"." s) [len (octet-pair->number (car start) (cadr start))]
s0) [start (cddr start)])
start)))] ;; Extract next len bytes for data:
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))] (let loop ([len len] [start start] [accum null])
[else (if (zero? len)
;; Compression offset (values (list name type class ttl (reverse! accum))
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) start)
(cadr start))]) (loop (sub1 len) (cdr start) (cons (car start) accum)))))))
(let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-rr 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))
[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))
(caddr start) (cadddr start))] classes))]
[start (cddddr start)]) [start (cddr start)])
(let ([len (octet-pair->number (car start) (cadr start))] (values (list name type class) start))))
[start (cddr start)])
; Extract next len bytes for data:
(let loop ([len len][start start][accum null])
(if (zero? len)
(values (list name type class ttl (reverse! accum))
start)
(loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
(define (parse-ques start reply) (define (parse-n parse start reply n)
(let-values ([(name start) (parse-name start reply)]) (let loop ([n n][start start][accum null])
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))] (if (zero? n)
[start (cddr start)]) (values (reverse! accum) start)
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))] (let-values ([(rr start) (parse start reply)])
[start (cddr start)]) (loop (sub1 n) start (cons rr accum))))))
(values (list name type class) start)))))
(define (parse-n parse start reply n) (define (dns-query nameserver addr type class)
(let loop ([n n][start start][accum null]) (unless (assoc type types)
(if (zero? n) (raise-type-error 'dns-query "DNS query type" type))
(values (reverse! accum) start) (unless (assoc class classes)
(let-values ([(rr start) (parse start reply)]) (raise-type-error 'dns-query "DNS query class" class))
(loop (sub1 n) start (cons rr accum))))))
(define (dns-query nameserver addr type class) (let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
(unless (assoc type types) type class)]
(raise-type-error 'dns-query "DNS query type" type)) [udp (udp-open-socket)]
(unless (assoc class classes) [reply
(raise-type-error 'dns-query "DNS query class" class)) (dynamic-wind
void
(lambda ()
(let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query))
(sync (handle-evt
(udp-receive!-evt udp s)
(lambda (r)
(bytes->list (subbytes s 0 (car r)))))
(handle-evt
(alarm-evt (+ (current-inexact-milliseconds)
timeout))
(lambda (v)
(retry (* timeout 2))))))))
(lambda () (udp-close udp)))])
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr) type class)] ;; First two bytes must match sent message id:
[udp (udp-open-socket)] (unless (and (= (car reply) (car query))
[reply (= (cadr reply) (cadr query)))
(dynamic-wind (error 'dns-query "bad reply id from server"))
void
(lambda () (let ([v0 (caddr reply)]
(let ([s (make-bytes 512)]) [v1 (cadddr reply)])
(let retry ([timeout INIT-TIMEOUT]) ;; Check for error code:
(udp-send-to udp nameserver 53 (list->bytes query)) (let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode)
(error 'dns-query "error from server: ~a"
(case rcode
[(1) "format error"]
[(2) "server failure"]
[(3) "name error"]
[(4) "not implemented"]
[(5) "refused"]))))
(sync (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
(handle-evt [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
(udp-receive!-evt udp s) [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
(lambda (r) [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
(bytes->list (subbytes s 0 (car r)))))
(handle-evt
(alarm-evt (+ (current-inexact-milliseconds)
timeout))
(lambda (v)
(retry (* timeout 2))))))))
(lambda () (let ([start (list-tail reply 12)])
(udp-close udp)))]) (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
[(ans start) (parse-n parse-rr start reply an-count)]
[(nss start) (parse-n parse-rr start reply ns-count)]
[(ars start) (parse-n parse-rr start reply ar-count)])
(unless (null? start)
(error 'dns-query "error parsing server reply"))
(values (positive? (bitwise-and #x4 v0))
qds ans nss ars reply)))))))
; First two bytes must match sent message id: (define cache (make-hash-table))
(unless (and (= (car reply) (car query)) (define (dns-query/cache nameserver addr type class)
(= (cadr reply) (cadr query))) (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
(error 'dns-query "bad reply id from server")) (let ([v (hash-table-get cache key (lambda () #f))])
(if v
(apply values v)
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
(hash-table-put! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply))))))
(let ([v0 (caddr reply)] (define (ip->string s)
[v1 (cadddr reply)]) (format "~a.~a.~a.~a"
; Check for error code: (list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
(let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode)
(error 'dns-query "error from server: ~a"
(case rcode
[(1) "format error"]
[(2) "server failure"]
[(3) "name error"]
[(4) "not implemented"]
[(5) "refused"]))))
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] (define (try-forwarding k nameserver)
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] (let loop ([nameserver nameserver][tried (list nameserver)])
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] ;; Normally the recusion is done for us, but it's technically optional
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) (let-values ([(v ars auth?) (k nameserver)])
(or v
(and (not auth?)
(let* ([ns (ormap (lambda (ar)
(and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar))))
ars)])
(and ns
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(let ([start (list-tail reply 12)]) (define (ip->in-addr.arpa ip)
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] (let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
[(ans start) (parse-n parse-rr start reply an-count)] ip)])
[(nss start) (parse-n parse-rr start reply ns-count)] (format "~a.~a.~a.~a.in-addr.arpa"
[(ars start) (parse-n parse-rr start reply ar-count)]) (list-ref result 4)
(unless (null? start) (list-ref result 3)
(error 'dns-query "error parsing server reply")) (list-ref result 2)
(values (positive? (bitwise-and #x4 v0)) (list-ref result 1))))
qds ans nss ars reply)))))))
(define cache (make-hash-table)) (define (get-ptr-list-from-ans ans)
(define (dns-query/cache nameserver addr type class) (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) ans))
(let ([v (hash-table-get cache key (lambda () #f))])
(if v
(apply values v)
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
(hash-table-put! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply))))))
(define (ip->string s) (define (dns-get-name nameserver ip)
(format "~a.~a.~a.~a" (or (try-forwarding
(list-ref s 0) (lambda (nameserver)
(list-ref s 1) (let-values ([(auth? qds ans nss ars reply)
(list-ref s 2) (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
(list-ref s 3))) (values (and (positive? (length (get-ptr-list-from-ans ans)))
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
(let-values ([(name null) (parse-name s reply)])
(bytes->string/latin-1 name))))
ars auth?)))
nameserver)
(error 'dns-get-name "bad ip address")))
(define (try-forwarding k nameserver) (define (get-a-list-from-ans ans)
(let loop ([nameserver nameserver][tried (list nameserver)]) (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
; Normally the recusion is done for us, but it's technically optional ans))
(let-values ([(v ars auth?) (k nameserver)])
(or v
(and (not auth?)
(let* ([ns (ormap
(lambda (ar)
(and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar))))
ars)])
(and ns
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(define ip->in-addr.arpa
(lambda (ip)
(let ((result (regexp-match "([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)" ip)))
(format "~a.~a.~a.~a.in-addr.arpa"
(list-ref result 4)
(list-ref result 3)
(list-ref result 2)
(list-ref result 1)))))
(define get-ptr-list-from-ans
(lambda (ans)
(filter (lambda (ans-entry)
(eq? (list-ref ans-entry 1) 'ptr))
ans)))
(define dns-get-name
(lambda (nameserver ip)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply)
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
(values (and (positive? (length (get-ptr-list-from-ans ans)))
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
(let-values (((name null) (parse-name s reply)))
(bytes->string/latin-1 name))))
ars auth?)))
nameserver)
(error 'dns-get-name "bad ip address"))))
(define get-a-list-from-ans
(lambda (ans)
(filter (lambda (ans-entry)
(eq? (list-ref ans-entry 1) 'a))
ans)))
(define (dns-get-address nameserver addr) (define (dns-get-address nameserver addr)
(or (try-forwarding (or (try-forwarding
(lambda (nameserver) (lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)]) (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
(values (and (positive? (length (get-a-list-from-ans ans))) (values (and (positive? (length (get-a-list-from-ans ans)))
(let ([s (rr-data (car (get-a-list-from-ans ans)))]) (let ([s (rr-data (car (get-a-list-from-ans ans)))])
(ip->string s))) (ip->string s)))
ars auth?))) ars auth?)))
nameserver) nameserver)
(error 'dns-get-address "bad address"))) (error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr) (define (dns-get-mail-exchanger nameserver addr)
(or (try-forwarding (or (try-forwarding
(lambda (nameserver) (lambda (nameserver)
(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)
;; Does 'soa mean that the input address is fine? (or exchanger
(and (ormap ;; Does 'soa mean that the input address is fine?
(lambda (ns) (eq? (rr-type ns) 'soa)) (and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
nss) nss)
addr))] addr))]
[else [else
(let ([d (rr-data (car ans))]) (let ([d (rr-data (car ans))])
(let ([pref (octet-pair->number (car d) (cadr d))]) (let ([pref (octet-pair->number (car d) (cadr d))])
(if (< pref best-pref) (if (< pref best-pref)
(let-values ([(name start) (parse-name (cddr d) reply)]) (let-values ([(name start) (parse-name (cddr d) reply)])
(loop (cdr ans) pref name)) (loop (cdr ans) pref name))
(loop (cdr ans) best-pref exchanger))))])) (loop (cdr ans) best-pref exchanger))))]))
ars auth?))) ars auth?)))
nameserver) nameserver)
(error 'dns-get-mail-exchanger "bad address"))) (error 'dns-get-mail-exchanger "bad address")))
(define (dns-find-nameserver) (define (dns-find-nameserver)
(case (system-type) (case (system-type)
[(unix macosx) [(unix macosx)
(with-handlers ([void (lambda (x) #f)]) (with-handlers ([void (lambda (x) #f)])
(with-input-from-file "/etc/resolv.conf" (with-input-from-file "/etc/resolv.conf"
(lambda () (lambda ()
(let loop () (let loop ()
(let ([l (read-line)]) (let ([l (read-line)])
(or (and (string? l) (or (and (string? l)
(let ([m (regexp-match (let ([m (regexp-match
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
l)]) l)])
(and m (cadr m)))) (and m (cadr m))))
(and (not (eof-object? l)) (and (not (eof-object? l))
(loop))))))))] (loop))))))))]
[(windows) [(windows)
(let ([nslookup (find-executable-path "nslookup.exe" #f)]) (let ([nslookup (find-executable-path "nslookup.exe" #f)])
(and nslookup (and nslookup
@ -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@)

10
collects/net/doc.txt
View File

@ -498,11 +498,11 @@ PROCEDURES -----------------------------------------------------------
> (smtp-send-message server-string from-string to-list-of-strings header > (smtp-send-message server-string from-string to-list-of-strings header
message-list-of-strings/bytes message-list-of-strings/bytes
[#:port-no k] [#:port-no k]
[#:auth-user user-string-or-#f] [#:auth-user user-string-or-#f]
[#:auth-passwd pw-string-or-#f] [#:auth-passwd pw-string-or-#f]
[#:tcp-connect proc] [#:tcp-connect proc]
[port-no]) -> void [port-no]) -> void
The first argument is the IP address of the SMTP server. The The first argument is the IP address of the SMTP server. The
`from-string' argument specifies the mail address of the sender, and `from-string' argument specifies the mail address of the sender, and

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)

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

@ -3,213 +3,215 @@
;; 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^)
;; opqaue record to represent an FTP connection: ;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out)) (define-struct tcp-connection (in out))
(define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) (define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ") (define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define (check-expected-result line expected) (define (check-expected-result line expected)
(when expected (when expected
(unless (ormap (lambda (expected) (unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3))) (bytes=? expected (subbytes line 0 3)))
(if (bytes? expected) (if (bytes? expected)
(list expected) (list expected)
expected)) expected))
(error 'ftp "exected result code ~a, got ~a" expected line)))) (error 'ftp "exected result code ~a, got ~a" expected line))))
;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
;; ;;
;; Checks a standard-format response, checking for the given ;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f. ;; expected 3-digit result code if expected is not #f.
;; ;;
;; While checking, the function sends reponse lines to ;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a ;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and ;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and ;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info. ;; `(void)' to ignore the response info.
;; ;;
;; If an unexpected result is found, an exception is raised, and the ;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state. ;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout) (flush-output tcpout)
(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:multi-response-start line) [(regexp-match re:multi-response-start line)
(check-expected-result line expected) (check-expected-result line expected)
(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)] [else
[else (loop (diagnostic-accum line accum))]))))]
(loop (diagnostic-accum line accum))]))))] [(regexp-match re:response-end line)
[(regexp-match re:response-end line) (check-expected-result line expected)
(check-expected-result line expected) (diagnostic-accum line accum-start)]
(diagnostic-accum line accum-start)] [else
[else (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)))
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define (ftp-make-file-seconds ftp-date-str) (define (ftp-make-file-seconds ftp-date-str)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4)) (if (not (list-ref date-list 4))
(find-seconds 0 (find-seconds 0
0 0
2 2
(bytes->number (list-ref date-list 6)) (bytes->number (list-ref date-list 6))
(get-month (list-ref date-list 5)) (get-month (list-ref date-list 5))
(bytes->number (list-ref date-list 7))) (bytes->number (list-ref date-list 7)))
(+ (find-seconds 0 (+ (find-seconds 0
(bytes->number (list-ref date-list 4)) (bytes->number (list-ref date-list 4))
(bytes->number (list-ref date-list 3)) (bytes->number (list-ref date-list 3))
(bytes->number (list-ref date-list 2)) (bytes->number (list-ref date-list 2))
(get-month (list-ref date-list 1)) (get-month (list-ref date-list 1))
2002) 2002)
tzoffset)))) tzoffset))))
(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-out tcp-ports) (tcp-connection-in tcp-ports)
#"227" (tcp-connection-out tcp-ports)
(lambda (s ignore) s) ;; should be the only response #"227"
(void))]) (lambda (s ignore) s) ; should be the only response
(let* ([reg-list (regexp-match re:passive response)] (void))])
[pn1 (and reg-list (let* ([reg-list (regexp-match re:passive response)]
(bytes->number (list-ref reg-list 5)))] [pn1 (and reg-list
[pn2 (bytes->number (list-ref reg-list 6))]) (bytes->number (list-ref reg-list 5)))]
(unless (and reg-list pn1 pn2) [pn2 (bytes->number (list-ref reg-list 6))])
(error 'ftp "can't understand PASV response: ~e" response)) (unless (and reg-list pn1 pn2)
(let-values ([(tcp-data tcp-data-out) (tcp-connect (format "~a.~a.~a.~a" (error 'ftp "can't understand PASV response: ~e" response))
(list-ref reg-list 1) (let-values ([(tcp-data tcp-data-out)
(list-ref reg-list 2) (tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 3) (list-ref reg-list 1)
(list-ref reg-list 4)) (list-ref reg-list 2)
(+ (* 256 pn1) pn2))]) (list-ref reg-list 3)
(fprintf (tcp-connection-out tcp-ports) "TYPE I~n") (list-ref reg-list 4))
(ftp-check-response (tcp-connection-in tcp-ports) (+ (* 256 pn1) pn2))])
(tcp-connection-out tcp-ports) (fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
#"200" void (void)) (ftp-check-response (tcp-connection-in tcp-ports)
(close-output-port tcp-data-out) (tcp-connection-out tcp-ports)
tcp-data)))) #"200" void (void))
(close-output-port tcp-data-out)
tcp-data))))
;; 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
(lambda (line 230?) in out (list #"331" #"230")
(or 230? (regexp-match #rx#"^230" line))) (lambda (line 230?)
#f)]) (or 230? (regexp-match #rx#"^230" line)))
(unless no-password? #f)])
(display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out) (unless no-password?
(ftp-check-response in out #"230" void (void)))) (display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
(make-tcp-connection in out)) out)
(ftp-check-response in out #"230" void (void))))
(make-tcp-connection in out))
(define (ftp-establish-connection server-address server-port username password) (define (ftp-establish-connection server-address server-port username password)
(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(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)
(close-input-port (tcp-connection-in tcp-ports)) (tcp-connection-out tcp-ports)
(close-output-port (tcp-connection-out tcp-ports))) #"221" void (void))
(close-input-port (tcp-connection-in tcp-ports))
(close-output-port (tcp-connection-out tcp-ports)))
(define (filter-tcp-data tcp-data-port regular-exp) (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) null]
(< (bytes-length theline) 3)) [(regexp-match regular-exp theline)
null] => (lambda (m) (cons (cdr m) (loop)))]
[(regexp-match regular-exp theline) [else
=> (lambda (m) ;; ignore unrecognized lines?
(cons (cdr m) (loop)))] (loop)]))))
[else
;; ignore unrecognized lines?
(loop)]))))
(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)
#"250" void (void))) (tcp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") (define re:dir-line
#rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define (ftp-directory-list tcp-ports) (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)
#"150" void (void)) (tcp-connection-out tcp-ports)
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) #"150" void (void))
(close-input-port tcp-data) (let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) (close-input-port tcp-data)
#"226" print-msg (void)) (ftp-check-response (tcp-connection-in tcp-ports)
(map (lambda (l) (map bytes->string/locale l)) dir-list)))) (tcp-connection-out tcp-ports)
#"226" print-msg (void))
(map (lambda (l) (map bytes->string/locale l)) dir-list))))
(define (ftp-download-file tcp-ports folder filename) (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
(path->string (build-path folder "ftptmp")) (regexp-replace
"~~") #rx"~"
"~a"))] (path->string (build-path folder "ftptmp"))
[new-file (open-output-file tmpfile 'replace)] "~~")
[tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")] "~a"))]
[tcp-data (establish-data-connection tcp-ports)]) [new-file (open-output-file tmpfile 'replace)]
(display tcpstring (tcp-connection-out tcp-ports)) [tcpstring (bytes-append #"RETR "
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) (string->bytes/locale filename)
#"150" print-msg (void)) #"\n")]
(copy-port tcp-data new-file) [tcp-data (establish-data-connection tcp-ports)])
(close-output-port new-file) (display tcpstring (tcp-connection-out tcp-ports))
(close-input-port tcp-data) (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)
#"226" print-msg (void)) #"150" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t))) (copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (printf "FTP Client Installed...~n") ;; (printf "FTP Client Installed...\n")
) )

4
collects/net/ftp.ss
View File

@ -1,7 +1,5 @@
(module ftp mzscheme (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)

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

@ -1,400 +1,348 @@
(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?
;; -- JBC 2006-07-31 ;; Easiest just to stop here.
;; -- JBC 2006-07-31
(define CRLF (string #\return #\newline)) (define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n") (define CRLF/bytes #"\r\n")
(define empty-header CRLF) (define empty-header CRLF)
(define empty-header/bytes CRLF/bytes) (define empty-header/bytes CRLF/bytes)
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:")) (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:") (define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(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)
(if (bytes? s)
;; legal char check not needed per rfc 2822, IIUC.
(let ([len (bytes-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(bytes=? CRLF/bytes (subbytes s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
[(or (regexp-match re:field-start/bytes s offset)
(regexp-match re:continue/bytes s offset))
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
(if m
(loop (cdar m))
(error 'validate-header/bytes "missing ending CRLF")))]
[else (error 'validate-header/bytes "ill-formed header at ~s"
(subbytes s offset (string-length s)))])))
;; otherwise it should be a string:
(begin
(let ([m (regexp-match #rx"[^\000-\377]" s)])
(when m
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
(let ([len (string-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(string=? CRLF (substring s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header "missing ending CRLF")]
[(or (regexp-match re:field-start s offset)
(regexp-match re:continue s offset))
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
(if m
(loop (cdar m))
(error 'validate-header "missing ending CRLF")))]
[else (error 'validate-header "ill-formed header at ~s"
(substring s offset (string-length s)))]))))))
(define (make-field-start-regexp field)
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(define (extract-field field header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(and m
(let ([s (subbytes header
(cdaddr m)
(bytes-length header))])
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
(if m
(subbytes s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
;; otherwise header & field should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(and m
(let ([s (substring header
(cdaddr m)
(string-length header))])
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
(if m
(substring s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (validate-header s) (define (replace-field field data header)
(if (bytes? s) (if (bytes? header)
;; legal char check not needed per rfc 2822, IIUC. (let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
(let ([len (bytes-length s)]) header)])
(let loop ([offset 0]) (if m
(cond (let* ([pre (subbytes header 0 (caaddr m))]
[(and (= (+ offset 2) len) [s (subbytes header (cdaddr m))]
(bytes=? CRLF/bytes (subbytes s offset len))) [m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
(void)] ; validated [rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")] (bytes-append pre (if data (insert-field field data rest) rest)))
[(or (regexp-match re:field-start/bytes s offset) (if data (insert-field field data header) header)))
(regexp-match re:continue/bytes s offset)) ;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions #rx#"\r\n" s offset)]) (let ([m (regexp-match-positions (make-field-start-regexp field)
(if m header)])
(loop (cdar m)) (if m
(error 'validate-header/bytes "missing ending CRLF")))] (let* ([pre (substring header 0 (caaddr m))]
[else (error 'validate-header/bytes "ill-formed header at ~s" [s (substring header (cdaddr m))]
(subbytes s offset (string-length s)))]))) [m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
;; otherwise it should be a string: [rest (if m (substring s (+ 2 (caar m))) empty-header)])
(begin (string-append pre (if data (insert-field field data rest) rest)))
(let ([m (regexp-match #rx"[^\000-\377]" s)]) (if data (insert-field field data header) header)))))
(when m
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
(let ([len (string-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(string=? CRLF (substring s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header "missing ending CRLF")]
[(or (regexp-match re:field-start s offset)
(regexp-match re:continue s offset))
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
(if m
(loop (cdar m))
(error 'validate-header "missing ending CRLF")))]
[else (error 'validate-header "ill-formed header at ~s"
(substring s offset (string-length s)))]))))))
(define (make-field-start-regexp field) (define (remove-field field header)
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f)))) (replace-field field #f header))
(define (make-field-start-regexp/bytes field) (define (insert-field field data header)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)"))) (if (bytes? header)
(let ([field (bytes-append field #": "data #"\r\n")])
(bytes-append field header))
;; otherwise field, data, & header should be strings:
(let ([field (format "~a: ~a\r\n" field data)])
(string-append field header))))
(define (append-headers a b)
(if (bytes? a)
(let ([alen (bytes-length a)])
(if (> alen 1)
(bytes-append (subbytes a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a)))
;; otherwise, a & b should be strings:
(let ([alen (string-length a)])
(if (> alen 1)
(string-append (substring a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a)))))
(define (extract-field field header) (define (extract-all-fields header)
(if (bytes? header) (if (bytes? header)
(let ([m (regexp-match-positions (let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(make-field-start-regexp/bytes field) (let loop ([start 0])
header)]) (let ([m (regexp-match-positions re header start)])
(and m (if m
(let ([s (subbytes header (let ([start (cdaddr m)]
(cdaddr m) [field-name (subbytes header (caaddr (cdr m))
(bytes-length header))]) (cdaddr (cdr m)))])
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) (let ([m2 (regexp-match-positions
(if m #rx#"\r\n[^: \r\n\"]*:"
(subbytes s 0 (caar m)) header
;; Rest of header is this field, but strip trailing CRLFCRLF: start)])
(if m2
(cons (cons field-name
(subbytes header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx#"\r\n\r\n$" (regexp-replace #rx#"\r\n\r\n$"
s (subbytes header start (bytes-length header))
"")))))) ""))))))
;; otherwise header & field should be strings: ;; malformed header:
(let ([m (regexp-match-positions null))))
(make-field-start-regexp field) ;; otherwise, header should be a string:
header)]) (let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(and m (let loop ([start 0])
(let ([s (substring header (let ([m (regexp-match-positions re header start)])
(cdaddr m) (if m
(string-length header))]) (let ([start (cdaddr m)]
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]) [field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
(if m (let ([m2 (regexp-match-positions
(substring s 0 (caar m)) #rx"\r\n[^: \r\n\"]*:" header start)])
;; Rest of header is this field, but strip trailing CRLFCRLF: (if m2
(cons (cons field-name
(substring header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx"\r\n\r\n$" (regexp-replace #rx"\r\n\r\n$"
s (substring header start (string-length header))
"")))))))) ""))))))
;; malformed header:
null))))))
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(define (replace-field field data header) (define (standard-message-header from tos ccs bccs subject)
(if (bytes? header) (let ([h (insert-field
(let ([m (regexp-match-positions "Subject" subject
(make-field-start-regexp/bytes field) (insert-field
header)]) "Date" (parameterize ([date-display-format 'rfc2822])
(date->string (seconds->date (current-seconds)) #t))
CRLF))])
;; NOTE: bccs don't go into the header; that's why they're "blind"
(let ([h (if (null? ccs)
h
(insert-field "CC" (assemble-address-field ccs) h))])
(let ([h (if (null? tos)
h
(insert-field "To" (assemble-address-field tos) h))])
(insert-field "From" from h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply string-append
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m (if m
(let ([pre (subbytes header (let ([n (extract-one-name (string-append prefix (cadr m)) form)]
0 [rest (extract-addresses (caddr m) form)])
(caaddr m))] (cons n rest))
[s (subbytes header (let ([n (extract-one-name (string-append prefix s) form)])
(cdaddr m) (list n)))))))))
(bytes-length header))])
(let* ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m
(subbytes s (+ 2 (caar m))
(bytes-length s))
empty-header/bytes)])
(bytes-append pre
(if data
(insert-field field data rest)
rest))))
(if data
(insert-field field data header)
header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions
(make-field-start-regexp field)
header)])
(if m
(let ([pre (substring header
0
(caaddr m))]
[s (substring header
(cdaddr m)
(string-length header))])
(let* ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m
(substring s (+ 2 (caar m))
(string-length s))
empty-header)])
(string-append pre
(if data
(insert-field field data rest)
rest))))
(if data
(insert-field field data header)
header)))))
(define (remove-field field header) (define (select-result form name addr full)
(replace-field field #f header)) (case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (insert-field field data header) (define (one-result form s)
(if (bytes? header) (select-result form s s s))
(let ([field (bytes-append field #": "data #"\r\n")])
(bytes-append field header))
;; otherwise field, data, & header should be strings:
(let ([field (format "~a: ~a\r\n"
field
data)])
(string-append field header))))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (append-headers a b) (define (extract-one-name orig form)
(if (bytes? a) (let loop ([s orig][form form])
(let ([alen (bytes-length a)]) (cond
(if (> alen 1) ;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
(bytes-append (subbytes a 0 (- alen 2)) b) [(regexp-match re:parened-name s)
(error 'append-headers "first argument is not a header: ~a" a))) => (lambda (m)
;; otherwise, a & b should be strings: (let ([name (caddr m)]
(let ([alen (string-length a)]) [all (loop (cadr m) 'all)])
(if (> alen 1) (select-result
(string-append (substring a 0 (- alen 2)) b) form
(error 'append-headers "first argument is not a header: ~a" a))))) (if (string=? (car all) (cadr all)) name (car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else (one-result form (extract-simple-addr s orig))])))
(define (extract-all-fields header) (define (extract-angle-addr s orig)
(if (bytes? header) (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"]) (error 'extract-address "too many angle brackets: ~a" s)
(let loop ([start 0]) (let ([m (regexp-match re:normal-name s)])
(let ([m (regexp-match-positions re header start)]) (if m
(if m (extract-simple-addr (cadr m) orig)
(let ([start (cdaddr m)] (error 'extract-address "cannot parse address: ~a" orig)))))
[field-name (subbytes header (caaddr (cdr m)) (cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx#"\r\n[^: \r\n\"]*:"
header
start)])
(if m2
(cons (cons field-name
(subbytes header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx#"\r\n\r\n$"
(subbytes header start (bytes-length header))
""))))))
;; malformed header:
null))))
;; otherwise, header should be a string:
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(let loop ([start 0])
(let ([m (regexp-match-positions re header start)])
(if m
(let ([start (cdaddr m)]
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx"\r\n[^: \r\n\"]*:"
header
start)])
(if m2
(cons (cons field-name
(substring header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx"\r\n\r\n$"
(substring header start (string-length header))
""))))))
;; malformed header:
null))))))
;; It's slightly less obvious how to generalize the functions that don't accept a header (define (extract-simple-addr s orig)
;; as input; for lack of an obvious solution (and free time), I'm stopping the string->bytes (cond [(regexp-match re:bad-chars s)
;; translation here. -- JBC, 2006-07-31 (error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define (standard-message-header from tos ccs bccs subject) (define (assemble-address-field addresses)
(let ([h (insert-field (if (null? addresses)
"Subject" subject ""
(insert-field (let loop ([addresses (cdr addresses)]
"Date" (parameterize ([date-display-format 'rfc2822]) [s (car addresses)]
(date->string (seconds->date (current-seconds)) #t)) [len (string-length (car addresses))])
CRLF))]) (if (null? addresses)
;; NOTE: bccs don't go into the header; that's why s
;; they're "blind" (let* ([addr (car addresses)]
(let ([h (if (null? ccs) [alen (string-length addr)])
h (if (<= 72 (+ len alen))
(insert-field (loop (cdr addresses)
"CC" (assemble-address-field ccs) (format "~a,~a~a~a~a"
h))]) s #\return #\linefeed
(let ([h (if (null? tos) #\tab addr)
h alen)
(insert-field (loop (cdr addresses)
"To" (assemble-address-field tos) (format "~a, ~a" s addr)
h))]) (+ len alen 2)))))))))
(insert-field
"From" from
h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply
string-append
(map
(lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
[rest (extract-addresses (caddr m) form)])
(cons n rest))
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (one-result form s)
(select-result form s s s))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (extract-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match re:parened-name s)
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result form
(if (string=? (car all) (cadr all))
name
(car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else
(one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match re:normal-name s)])
(if m
(extract-simple-addr (cadr m) orig)
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(cond
[(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace
re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]
[s (car addresses)]
[len (string-length (car addresses))])
(if (null? addresses)
s
(let* ([addr (car addresses)]
[alen (string-length addr)])
(if (<= 72 (+ len alen))
(loop (cdr addresses)
(format "~a,~a~a~a~a"
s #\return #\linefeed
#\tab addr)
alen)
(loop (cdr addresses)
(format "~a, ~a" s addr)
(+ len alen 2)))))))))

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)

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

File diff suppressed because it is too large Load Diff

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

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

File diff suppressed because it is too large Load Diff

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

@ -40,22 +40,22 @@
;; 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))))
(list s))))))) (list s)))))))
;; Trim all spaces, except those in quoted strings. ;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\"")) (define re:quote-start (regexp "\""))
@ -65,30 +65,30 @@
;; Break out alternate quoted and unquoted parts. ;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted. ;; Initial and final string are unquoted.
(let-values ([(unquoted quoted) (let-values ([(unquoted quoted)
(let loop ([str str][unquoted null][quoted null]) (let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)]) (let ([m (regexp-match-positions re:quote-start str)])
(if m (if m
(let ([prefix (substring str 0 (caar m))] (let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))]) [rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote ;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)]) (let ([m (regexp-match-positions re:quote-start rest)])
(if m (if m
(let ([inside (substring rest 0 (caar m))] (let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))]) [rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted))) (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote! ;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted))))) (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))]) (values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts: ;; Put the pieces back together, stripping spaces for unquoted parts:
(apply (apply
string-append string-append
(let loop ([unquoted unquoted][quoted quoted]) (let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")]) (let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted) (if (null? quoted)
(list clean) (list clean)
(list* clean (list* clean
(car quoted) (car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))) (loop (cdr unquoted) (cdr quoted))))))))))
;; Only trims left and right spaces: ;; Only trims left and right spaces:
(define trim-spaces (define trim-spaces
@ -108,39 +108,41 @@
(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)))
str)))) str))))
(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

4
collects/net/mime.ss
View File

@ -34,8 +34,8 @@
"qp.ss" "qp.ss"
"base64-sig.ss" "base64-sig.ss"
"base64.ss" "base64.ss"
"head-sig.ss" "head-sig.ss"
"head.ss") "head.ss")
(define-unit-from-context base64@ base64^) (define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^) (define-unit-from-context qp@ qp^)

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

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

@ -1,337 +1,331 @@
(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^)
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
;; server : string ;; server : string
;; port : number ;; port : number
(define-struct communicator (sender receiver server port)) (define-struct communicator (sender receiver server port))
;; code : number ;; code : number
;; text : string ;; text : string
;; line : string ;; line : string
;; communicator : communicator ;; communicator : communicator
;; group : string ;; group : string
;; article : number ;; article : number
(define-struct (nntp exn) ()) (define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text)) (define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line)) (define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator)) (define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line)) (define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group)) (define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article)) (define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ()) (define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article)) (define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ()) (define-struct (authentication-rejected nntp) ())
;; signal-error : ;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
;; - throws an exception ;; - throws an exception
(define signal-error (define signal-error
(lambda (constructor format-string . args) (lambda (constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(string->immutable-string (apply format format-string args)) (string->immutable-string (apply format format-string args))
(current-continuation-marks) (current-continuation-marks)
exn-args))))) exn-args)))))
;; default-nntpd-port-number : ;; default-nntpd-port-number :
;; number ;; number
(define default-nntpd-port-number 119) (define default-nntpd-port-number 119)
;; connect-to-server*: ;; connect-to-server*:
;; input-port output-port -> communicator ;; input-port output-port -> communicator
(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) "unexpected connection response: ~s ~s"
(else code response)
((signal-error make-unexpected-response code response)])))]))
"unexpected connection response: ~s ~s"
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 :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define close-communicator
(lambda (communicator) (lambda (communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))) (close-output-port (communicator-sender communicator))))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(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 -> ()
;; the password is not used if the server does not ask for it. ;; the password is not used if the server does not ask for it.
(define authenticate-user (define authenticate-user
(lambda (communicator user password) (lambda (communicator user password)
(define (reject code response) (define (reject code response)
((signal-error make-authentication-rejected ((signal-error make-authentication-rejected
"authentication rejected (~s ~s)" "authentication rejected (~s ~s)"
code response))) code response)))
(define (unexpected code response) (define (unexpected code response)
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected response for authentication: ~s ~s" "unexpected response for authentication: ~s ~s"
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
[(281) (void)] ; server doesn't ask for a password
[(381)
(send-to-server communicator "AUTHINFO PASS ~a" password)
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(281) (void)] ; done
[(502) (reject code response)]
[else (unexpected code response)]))]
[(502) (reject code response)]
[else (reject code response)
(unexpected code response)]))))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define send-to-server
(lambda (communicator message-template . rest)
(let ([sender (communicator-sender communicator)])
(apply fprintf sender
(string-append message-template "\r\n")
rest)
(flush-output sender))))
;; parse-status-line :
;; string -> number x string
(define parse-status-line
(lambda (line)
(if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line")
line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))])
(values (string->number (car match))
(cadr match))))))
;; get-one-line-from-server :
;; iport -> string
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
;; get-single-line-response :
;; communicator -> number x string
(define get-single-line-response
(lambda (communicator)
(let ([receiver (communicator-receiver communicator)])
(let ([status-line (get-one-line-from-server receiver)])
(parse-status-line status-line)))))
;; get-rest-of-multi-line-response :
;; communicator -> list (string)
(define get-rest-of-multi-line-response
(lambda (communicator)
(let ([receiver (communicator-receiver communicator)])
(let loop ()
(let ([l (get-one-line-from-server receiver)])
(cond
[(eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator)]
[(string=? l ".")
'()]
[(string=? l "..")
(cons "." (loop))]
[else
(cons l (loop))]))))))
;; get-multi-line-response :
;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines.
(define get-multi-line-response
(lambda (communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line)
(parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response))))))
;; open-news-group :
;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group.
(define open-news-group
(lambda (communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line)
(get-single-line-response communicator)])
(case code
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)]))))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
(define generic-message-command
(lambda (command ok-code)
(lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a")
(if (number? message-index)
(number->string message-index)
message-index))
(let-values ([(code response)
(get-single-line-response communicator)])
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code (case code
((281) (void)) ; server doesn't ask for a password [(423)
((381) ((signal-error make-article-not-in-group
(send-to-server communicator "AUTHINFO PASS ~a" password) "article id ~s not in group" message-index)
(let-values (((code response) message-index)]
(get-single-line-response communicator))) [(412)
(case code ((signal-error make-no-group-selected
((281) (void)) ; done "no group selected"))]
((502) (reject code response)) [(430)
(else (unexpected code response))))) ((signal-error make-article-not-found
((502) (reject code response)) "no article id ~s found" message-index)
(else (reject code response) message-index)]
(unexpected code response)))))) [else
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define send-to-server
(lambda (communicator message-template . rest)
(let ([sender (communicator-sender communicator)])
(apply fprintf sender
(string-append message-template "\r\n")
rest)
(flush-output sender))))
;; parse-status-line :
;; string -> number x string
(define parse-status-line
(lambda (line)
(if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line")
line)
(let ((match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))))
(values (string->number (car match))
(cadr match))))))
;; get-one-line-from-server :
;; iport -> string
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
;; get-single-line-response :
;; communicator -> number x string
(define get-single-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(parse-status-line status-line)))))
;; get-rest-of-multi-line-response :
;; communicator -> list (string)
(define get-rest-of-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let loop ()
(let ((l (get-one-line-from-server receiver)))
(cond
((eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator))
((string=? l ".")
'())
((string=? l "..")
(cons "." (loop)))
(else
(cons l (loop)))))))))
;; get-multi-line-response :
;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines.
(define get-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(let-values (((code rest-of-line)
(parse-status-line status-line)))
(values code rest-of-line (get-rest-of-multi-line-response)))))))
;; open-news-group :
;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group.
(define open-news-group
(lambda (communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values (((code rest-of-line)
(get-single-line-response communicator)))
(case code
((211)
(let ((match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))))
(let ((number-of-articles (car match))
(first-article-number (cadr match))
(last-article-number (caddr match)))
(values number-of-articles
first-article-number
last-article-number))))
((411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name))
(else
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected group opening response: ~s" code) "unexpected message access response: ~s" code)
code rest-of-line)))))) code response)]))))))
;; generic-message-command : ;; head-of-message :
;; string x number -> communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define generic-message-command (define head-of-message
(lambda (command ok-code) (generic-message-command "HEAD" 221))
(lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a")
(if (number? message-index)
(number->string message-index)
message-index))
(let-values (((code response)
(get-single-line-response communicator)))
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code
((423)
((signal-error make-article-not-in-group
"article id ~s not in group" message-index)
message-index))
((412)
((signal-error make-no-group-selected
"no group selected")))
((430)
((signal-error make-article-not-found
"no article id ~s found" message-index)
message-index))
(else
((signal-error make-unexpected-response
"unexpected message access response: ~s" code)
code response))))))))
;; head-of-message : ;; body-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define head-of-message (define body-of-message
(generic-message-command "HEAD" 221)) (generic-message-command "BODY" 222))
;; body-of-message : ;; newnews-since :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define body-of-message (define newnews-since
(generic-message-command "BODY" 222)) (generic-message-command "NEWNEWS" 230))
;; newnews-since : ;; make-desired-header :
;; communicator x (number U string) -> list (string) ;; string -> desired
(define newnews-since (define make-desired-header
(generic-message-command "NEWNEWS" 230)) (lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":"))))
;; make-desired-header : ;; extract-desired-headers :
;; string -> desired ;; list (string) x list (desired) -> list (string)
(define make-desired-header
(lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
(string->list raw-header))))
":"))))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))
(define extract-desired-headers
(lambda (headers desireds)
(let loop ([headers headers])
(if (null? headers) null
(let ([first (car headers)]
[rest (cdr headers)])
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))

4
collects/net/nntp.ss
View File

@ -1,7 +1,5 @@
(module nntp mzscheme (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@)

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

@ -1,410 +1,405 @@
(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^)
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
;; server : string ;; server : string
;; port : number ;; port : number
;; state : symbol = (disconnected, authorization, transaction) ;; state : symbol = (disconnected, authorization, transaction)
(define-struct communicator (sender receiver server port state)) (define-struct communicator (sender receiver server port state))
(define-struct (pop3 exn) ()) (define-struct (pop3 exn) ())
(define-struct (cannot-connect pop3) ()) (define-struct (cannot-connect pop3) ())
(define-struct (username-rejected pop3) ()) (define-struct (username-rejected pop3) ())
(define-struct (password-rejected pop3) ()) (define-struct (password-rejected pop3) ())
(define-struct (not-ready-for-transaction pop3) (communicator)) (define-struct (not-ready-for-transaction pop3) (communicator))
(define-struct (not-given-headers pop3) (communicator message)) (define-struct (not-given-headers pop3) (communicator message))
(define-struct (illegal-message-number pop3) (communicator message)) (define-struct (illegal-message-number pop3) (communicator message))
(define-struct (cannot-delete-message exn) (communicator message)) (define-struct (cannot-delete-message exn) (communicator message))
(define-struct (disconnect-not-quiet pop3) (communicator)) (define-struct (disconnect-not-quiet pop3) (communicator))
(define-struct (malformed-server-response pop3) (communicator)) (define-struct (malformed-server-response pop3) (communicator))
;; signal-error : ;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
(define signal-error (define signal-error
(lambda (constructor format-string . args) (lambda (constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(string->immutable-string (string->immutable-string
(apply format format-string args)) (apply format format-string args))
(current-continuation-marks) (current-continuation-marks)
exn-args))))) exn-args)))))
;; signal-malformed-response-error : ;; signal-malformed-response-error :
;; exn-args -> () ;; exn-args -> ()
;; -- in practice, it takes only one argument: a communicator. ;; -- in practice, it takes only one argument: a communicator.
(define signal-malformed-response-error (define signal-malformed-response-error
(signal-error make-malformed-server-response (signal-error make-malformed-server-response
"malformed response from server")) "malformed response from server"))
;; confirm-transaction-mode : ;; confirm-transaction-mode :
;; communicator x string -> () ;; communicator x string -> ()
;; -- signals an error otherwise. ;; -- signals an error otherwise.
(define confirm-transaction-mode (define confirm-transaction-mode
(lambda (communicator error-message) (lambda (communicator error-message)
(unless (eq? (communicator-state communicator) 'transaction) (unless (eq? (communicator-state communicator) 'transaction)
((signal-error make-not-ready-for-transaction error-message) ((signal-error make-not-ready-for-transaction error-message)
communicator)))) communicator))))
;; default-pop-port-number : ;; default-pop-port-number :
;; number ;; number
(define default-pop-port-number 110) (define default-pop-port-number 110)
(define-struct server-responses ()) (define-struct server-responses ())
(define-struct (+ok server-responses) ()) (define-struct (+ok server-responses) ())
(define-struct (-err server-responses) ()) (define-struct (-err server-responses) ())
;; connect-to-server*: ;; connect-to-server*:
;; input-port output-port -> communicator ;; input-port output-port -> communicator
(define connect-to-server* (define connect-to-server*
(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 :
;; string x string x communicator -> () ;; string x string x communicator -> ()
;; -- if authentication succeeds, sets the communicator's state to ;; -- if authentication succeeds, sets the communicator's state to
;; transaction. ;; transaction.
(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
;; -- returns number of messages and number of octets. ;; -- returns number of messages and number of octets.
(define get-mailbox-status (define get-mailbox-status
(lambda (communicator) (lambda (communicator)
(confirm-transaction-mode (confirm-transaction-mode
communicator communicator
"cannot get mailbox status unless in transaction mode") "cannot get mailbox status unless in transaction mode")
(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 :
;; communicator x number -> list (string) x list (string) ;; communicator x number -> list (string) x list (string)
(define get-message/complete (define get-message/complete
(lambda (communicator message) (lambda (communicator message)
(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)
(define get-message/headers (define get-message/headers
(lambda (communicator message) (lambda (communicator message)
(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 :
;; list (string) -> list (string) x list (string) ;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines. ;; -- returns list of headers and list of body lines.
(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))))))))
;; delete-message : ;; delete-message :
;; communicator x number -> () ;; communicator x number -> ()
(define delete-message (define delete-message
(lambda (communicator message) (lambda (communicator message)
(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
(define uidl-regexp #rx"([0-9]+) (.*)") (define uidl-regexp #rx"([0-9]+) (.*)")
;; get-unique-id/single : ;; get-unique-id/single :
;; communicator x number -> string ;; communicator x number -> string
(define (get-unique-id/single communicator message) (define (get-unique-id/single communicator message)
(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
".*"))) ;; +OK 2 QhdPYR:00WBw1Ph7x7
;; The server response is of the form (cond
;; +OK 2 QhdPYR:00WBw1Ph7x7 [(-err? status)
(cond ((signal-error make-illegal-message-number
((-err? status) "no message numbered ~a available for unique id" message)
((signal-error make-illegal-message-number communicator message)]
"no message numbered ~a available for unique id" message) [(+ok? status)
communicator message)) (cadr result)])))
((+ok? status)
(cadr result)))))
;; get-unique-id/all : ;; get-unique-id/all :
;; communicator -> list(number x string) ;; communicator -> list(number x string)
(define (get-unique-id/all communicator) (define (get-unique-id/all communicator)
(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))))
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define close-communicator
(lambda (communicator) (lambda (communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))) (close-output-port (communicator-sender communicator))))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define disconnect-from-server
(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) -> ()
(define send-to-server (define send-to-server
(lambda (communicator message-template . rest) (lambda (communicator message-template . rest)
(apply fprintf (communicator-sender communicator) (apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output (communicator-sender communicator)))) (flush-output (communicator-sender communicator))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define get-one-line-from-server (define get-one-line-from-server
(lambda (server->client-port) (lambda (server->client-port)
(read-line server->client-port 'return-linefeed))) (read-line server->client-port 'return-linefeed)))
;; get-server-status-response : ;; get-server-status-response :
;; communicator -> server-responses x string ;; communicator -> server-responses x string
;; -- provides the low-level functionality of checking for +OK ;; -- provides the low-level functionality of checking for +OK
;; and -ERR, returning an appropriate structure, and returning the ;; and -ERR, returning an appropriate structure, and returning the
;; rest of the status response as a string to be used for further ;; rest of the status response as a string to be used for further
;; parsing, if necessary. ;; parsing, if necessary.
(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
(values (make-+ok) (cadr r))
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r (if r
(values (make-+ok) (cadr r)) (values (make--err) (cadr r))
(let ((r (regexp-match #rx"^\\-ERR(.*)" status-line))) (signal-malformed-response-error communicator)))))))
(if r
(values (make--err) (cadr r))
(signal-malformed-response-error communicator)))))))
;; get-status-response/basic : ;; get-status-response/basic :
;; communicator -> server-responses ;; communicator -> server-responses
;; -- when the only thing to determine is whether the response ;; -- when the only thing to determine is whether the response
;; was +OK or -ERR. ;; was +OK or -ERR.
(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 :
;; communicator x regexp x regexp -> (status x list (string)) ;; communicator x regexp x regexp -> (status x list (string))
;; -- when further parsing of the status response is necessary. ;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match. ;; Strips off the car of response from regexp-match.
(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))))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(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
(define make-desired-header (define make-desired-header
(lambda (raw-header) (lambda (raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
(list->string (list->string
(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))))
":")))) ":"))))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))
(define extract-desired-headers
(lambda (headers desireds)
(let loop ([headers headers])
(if (null? headers) null
(let ([first (car headers)]
[rest (cdr headers)])
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))

5
collects/net/pop3.ss
View File

@ -1,7 +1,5 @@
(module pop3 mzscheme (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)
|# |#

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

@ -20,8 +20,8 @@
(module rbtree mzscheme (module rbtree mzscheme
(provide new-tree tree-empty? (provide new-tree tree-empty?
expunge-insert! expunge-tree->list expunge-insert! expunge-tree->list
fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list) fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
(define-struct tree (v red? left-count left right parent) (make-inspector)) (define-struct tree (v red? left-count left right parent) (make-inspector))
@ -33,164 +33,164 @@
(define (k+ a b) (define (k+ a b)
(cons (+ (car a) (if (number? b) b (car b))) (cons (+ (car a) (if (number? b) b (car b)))
(cdr a))) (cdr a)))
(define (k- a b) (define (k- a b)
(cons (- (car a) (if (number? b) b (car b))) (cons (- (car a) (if (number? b) b (car b)))
(cdr a))) (cdr a)))
(define kv car) (define kv car)
(define (mk-insert sort-to-left? sort=? right+ (define (mk-insert sort-to-left? sort=? right+
left-insert-adjust! left-insert-adjust!
left-rotate-adjust! right-rotate-adjust!) left-rotate-adjust! right-rotate-adjust!)
(define-values (rotate-left! rotate-right!) (define-values (rotate-left! rotate-right!)
(let ([mk (let ([mk
(lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!) (lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!)
(lambda (t) (lambda (t)
(let ([old-east (tree-east t)]) (let ([old-east (tree-east t)])
(let ([r (tree-west old-east)]) (let ([r (tree-west old-east)])
(set-tree-east! t r) (set-tree-east! t r)
(when r (when r
(set-tree-parent! r t))) (set-tree-parent! r t)))
(let ([p (tree-parent t)]) (let ([p (tree-parent t)])
(set-tree-parent! old-east p) (set-tree-parent! old-east p)
(if (eq? t (tree-left p)) (if (eq? t (tree-left p))
(set-tree-left! p old-east) (set-tree-left! p old-east)
(set-tree-right! p old-east))) (set-tree-right! p old-east)))
(set-tree-west! old-east t) (set-tree-west! old-east t)
(set-tree-parent! t old-east) (set-tree-parent! t old-east)
(adj-count! t old-east))))]) (adj-count! t old-east))))])
(values (mk tree-left tree-right set-tree-left! set-tree-right! (values (mk tree-left tree-right set-tree-left! set-tree-right!
left-rotate-adjust!) left-rotate-adjust!)
(mk tree-right tree-left set-tree-right! set-tree-left! (mk tree-right tree-left set-tree-right! set-tree-left!
right-rotate-adjust!)))) right-rotate-adjust!))))
(values (values
;; insert ;; insert
(lambda (pre-root n) (lambda (pre-root n)
(let ([new (let ([new
;; Insert: ;; Insert:
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n] [n n]
[parent pre-root] [parent pre-root]
[set-child! (lambda (t v) [set-child! (lambda (t v)
(set-tree-left! pre-root v))]) (set-tree-left! pre-root v))])
(cond (cond
[(not t) (let ([new (make-tree n #t 0 #f #f parent)]) [(not t) (let ([new (make-tree n #t 0 #f #f parent)])
(set-child! parent new) (set-child! parent new)
new)] new)]
[(sort=? n t) [(sort=? n t)
(set-tree-v! t n) (set-tree-v! t n)
pre-root] pre-root]
[(sort-to-left? n t) [(sort-to-left? n t)
(left-insert-adjust! t) (left-insert-adjust! t)
(loop (tree-left t) n t set-tree-left!)] (loop (tree-left t) n t set-tree-left!)]
[else [else
(loop (tree-right t) (right+ n t) t set-tree-right!)]))]) (loop (tree-right t) (right+ n t) t set-tree-right!)]))])
;; Restore red-black property: ;; Restore red-black property:
(let loop ([v new]) (let loop ([v new])
(let ([p (tree-parent v)]) (let ([p (tree-parent v)])
(when (and p (tree-red? p)) (when (and p (tree-red? p))
(let ([gp (tree-parent p)]) (let ([gp (tree-parent p)])
(let-values ([(tree-west tree-east rotate-west! rotate-east!) (let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? p (tree-left gp)) (if (eq? p (tree-left gp))
(values tree-left tree-right rotate-left! rotate-right!) (values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))]) (values tree-right tree-left rotate-right! rotate-left!))])
(let ([uncle (tree-east (tree-parent p))]) (let ([uncle (tree-east (tree-parent p))])
(if (and uncle (tree-red? uncle)) (if (and uncle (tree-red? uncle))
(begin (begin
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! uncle #f) (set-tree-red?! uncle #f)
(set-tree-red?! gp #t) (set-tree-red?! gp #t)
(loop gp)) (loop gp))
(let ([finish (lambda (v) (let ([finish (lambda (v)
(let* ([p (tree-parent v)] (let* ([p (tree-parent v)]
[gp (tree-parent p)]) [gp (tree-parent p)])
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! gp #t) (set-tree-red?! gp #t)
(rotate-east! gp) (rotate-east! gp)
(loop gp)))]) (loop gp)))])
(if (eq? v (tree-east p)) (if (eq? v (tree-east p))
(begin (begin
(rotate-west! p) (rotate-west! p)
(finish p)) (finish p))
(finish v)))))))))) (finish v))))))))))
(set-tree-red?! (tree-left pre-root) #f))) (set-tree-red?! (tree-left pre-root) #f)))
;; delete (fetch only) ;; delete (fetch only)
(lambda (pre-root n) (lambda (pre-root n)
(let ([orig-t (fetch-find-node pre-root n)]) (let ([orig-t (fetch-find-node pre-root n)])
(when orig-t (when orig-t
;; Delete note t if it has at most one child. ;; Delete note t if it has at most one child.
;; Otherwise, move a leaf's data to here, and ;; Otherwise, move a leaf's data to here, and
;; delete the leaf. ;; delete the leaf.
(let ([t (if (and (tree-left orig-t) (let ([t (if (and (tree-left orig-t)
(tree-right orig-t)) (tree-right orig-t))
(let loop ([t (tree-right orig-t)]) (let loop ([t (tree-right orig-t)])
(if (tree-left t) (if (tree-left t)
(loop (tree-left t)) (loop (tree-left t))
t)) t))
orig-t)]) orig-t)])
(unless (eq? t orig-t) (unless (eq? t orig-t)
;; Swap out: ;; Swap out:
(let ([delta (kv (tree-v t))]) (let ([delta (kv (tree-v t))])
(set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t))) (set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t)))
(let loop ([c (tree-right orig-t)]) (let loop ([c (tree-right orig-t)])
(when c (when c
(set-tree-v! c (k- (tree-v c) delta)) (set-tree-v! c (k- (tree-v c) delta))
(loop (tree-left c)))))) (loop (tree-left c))))))
;; Now we can delete t: ;; Now we can delete t:
(let ([child-t (or (tree-left t) (let ([child-t (or (tree-left t)
(tree-right t))] (tree-right t))]
[p (tree-parent t)]) [p (tree-parent t)])
(when child-t (when child-t
(set-tree-parent! child-t p) (set-tree-parent! child-t p)
;; Adjust relative index of left spine of the ;; Adjust relative index of left spine of the
;; right branch (in the case that there was only ;; right branch (in the case that there was only
;; a right branch) ;; a right branch)
(let loop ([c (tree-right t)]) (let loop ([c (tree-right t)])
(when c (when c
(set-tree-v! c (k+ (tree-v c) (tree-v t))) (set-tree-v! c (k+ (tree-v c) (tree-v t)))
(loop (tree-left c))))) (loop (tree-left c)))))
(if (eq? (tree-left p) t) (if (eq? (tree-left p) t)
(set-tree-left! p child-t) (set-tree-left! p child-t)
(set-tree-right! p child-t)) (set-tree-right! p child-t))
;; Restore red-black property: ;; Restore red-black property:
(when (not (tree-red? t)) (when (not (tree-red? t))
(let loop ([c child-t] [p p]) (let loop ([c child-t] [p p])
(cond (cond
[(and c (tree-red? c)) (set-tree-red?! c #f)] [(and c (tree-red? c)) (set-tree-red?! c #f)]
[(tree-parent p) [(tree-parent p)
(let-values ([(tree-west tree-east rotate-west! rotate-east!) (let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? c (tree-left p)) (if (eq? c (tree-left p))
(values tree-left tree-right rotate-left! rotate-right!) (values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))]) (values tree-right tree-left rotate-right! rotate-left!))])
(let ([sibling (tree-east p)]) (let ([sibling (tree-east p)])
(let ([z (if (tree-red? sibling) (let ([z (if (tree-red? sibling)
(begin (begin
(set-tree-red?! sibling #f) (set-tree-red?! sibling #f)
(set-tree-red?! p #t) (set-tree-red?! p #t)
(rotate-west! p) (rotate-west! p)
(tree-east p)) (tree-east p))
sibling)]) sibling)])
(if (not (or (and (tree-west z) (if (not (or (and (tree-west z)
(tree-red? (tree-west z))) (tree-red? (tree-west z)))
(and (tree-east z) (and (tree-east z)
(tree-red? (tree-east z))))) (tree-red? (tree-east z)))))
(begin (begin
(set-tree-red?! z #t) (set-tree-red?! z #t)
(loop p (tree-parent p))) (loop p (tree-parent p)))
(let ([w (if (not (and (tree-east z) (let ([w (if (not (and (tree-east z)
(tree-red? (tree-east z)))) (tree-red? (tree-east z))))
(begin (begin
(set-tree-red?! (tree-west z) #f) (set-tree-red?! (tree-west z) #f)
(set-tree-red?! z #t) (set-tree-red?! z #t)
(rotate-east! z) (rotate-east! z)
(tree-east p)) (tree-east p))
z)]) z)])
(set-tree-red?! w (tree-red? p)) (set-tree-red?! w (tree-red? p))
(set-tree-red?! p #f) (set-tree-red?! p #f)
(set-tree-red?! (tree-east w) #f) (set-tree-red?! (tree-east w) #f)
(rotate-west! p))))))])))))))))) (rotate-west! p))))))]))))))))))
(define-values (expunge-insert! ---) (define-values (expunge-insert! ---)
(mk-insert (mk-insert
@ -208,13 +208,13 @@
;; left-rotate-adjust! ;; left-rotate-adjust!
(lambda (t old-right) (lambda (t old-right)
(set-tree-left-count! old-right (+ 1 (set-tree-left-count! old-right (+ 1
(tree-left-count old-right) (tree-left-count old-right)
(tree-left-count t)))) (tree-left-count t))))
;; right-rotate-adjust! ;; right-rotate-adjust!
(lambda (t old-left) (lambda (t old-left)
(set-tree-left-count! t (- (tree-left-count t) (set-tree-left-count! t (- (tree-left-count t)
(tree-left-count old-left) (tree-left-count old-left)
1))))) 1)))))
(define-values (fetch-insert! fetch-delete!) (define-values (fetch-insert! fetch-delete!)
(mk-insert (mk-insert
@ -232,28 +232,28 @@
;; left-rotate-adjust! ;; left-rotate-adjust!
(lambda (t old-right) (lambda (t old-right)
(set-tree-v! old-right (k+ (tree-v old-right) (set-tree-v! old-right (k+ (tree-v old-right)
(tree-v t)))) (tree-v t))))
;; right-rotate-adjust! ;; right-rotate-adjust!
(lambda (t old-left) (lambda (t old-left)
(set-tree-v! t (k- (tree-v t) (set-tree-v! t (k- (tree-v t)
(tree-v old-left)))))) (tree-v old-left))))))
(define (expunge-tree->list pre-root) (define (expunge-tree->list pre-root)
(let loop ([t (tree-left pre-root)]) (let loop ([t (tree-left pre-root)])
(if t (if t
(append (loop (tree-left t)) (append (loop (tree-left t))
(list (tree-v t)) (list (tree-v t))
(loop (tree-right t))) (loop (tree-right t)))
null))) null)))
(define (fetch-find-node pre-root n) (define (fetch-find-node pre-root n)
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n]) [n n])
(and t (and t
(cond (cond
[(= n (kv (tree-v t))) t] [(= n (kv (tree-v t))) t]
[(< n (kv (tree-v t))) (loop (tree-left t) n)] [(< n (kv (tree-v t))) (loop (tree-left t) n)]
[else (loop (tree-right t) (- n (kv (tree-v t))))])))) [else (loop (tree-right t) (- n (kv (tree-v t))))]))))
(define (fetch-find pre-root n) (define (fetch-find pre-root n)
(let ([t (fetch-find-node pre-root n)]) (let ([t (fetch-find-node pre-root n)])
@ -262,22 +262,22 @@
(define (fetch-shift! pre-root n) (define (fetch-shift! pre-root n)
(fetch-delete! pre-root n) (fetch-delete! pre-root n)
(let loop ([t (tree-left pre-root)] (let loop ([t (tree-left pre-root)]
[n n]) [n n])
(when t (when t
(if (n . < . (kv (tree-v t))) (if (n . < . (kv (tree-v t)))
(begin (begin
(set-tree-v! t (k- (tree-v t) 1)) (set-tree-v! t (k- (tree-v t) 1))
(loop (tree-left t) n)) (loop (tree-left t) n))
(loop (tree-right t) (loop (tree-right t)
(- n (kv (tree-v t)))))))) (- n (kv (tree-v t))))))))
(define (fetch-tree->list pre-root) (define (fetch-tree->list pre-root)
(let loop ([t (tree-left pre-root)][d 0]) (let loop ([t (tree-left pre-root)][d 0])
(if t (if t
(append (loop (tree-left t) d) (append (loop (tree-left t) d)
(list (k+ (tree-v t) d)) (list (k+ (tree-v t) d))
(loop (tree-right t) (+ d (kv (tree-v t))))) (loop (tree-right t) (+ d (kv (tree-v t)))))
null)))) null))))
#| #|
@ -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))))
@ -356,32 +356,32 @@ Tests:
(cons (cons
(cons n l) (cons n l)
(map (lambda (r) (cons (car l) r)) (map (lambda (r) (cons (car l) r))
(in-all-positions n (cdr l)))))) (in-all-positions n (cdr l))))))
(define (permutations l) (define (permutations l)
(if (or (null? l) (if (or (null? l)
(null? (cdr l))) (null? (cdr l)))
(list l) (list l)
(apply (apply
append append
(map (lambda (lol) (map (lambda (lol)
(in-all-positions (car l) lol)) (in-all-positions (car l) lol))
(permutations (cdr l)))))) (permutations (cdr l))))))
(define perms (permutations '(1 2 3 4 5 6 7 8))) (define perms (permutations '(1 2 3 4 5 6 7 8)))
(for-each (lambda (l) (for-each (lambda (l)
(let ([t (new-tree)]) (let ([t (new-tree)])
(for-each (lambda (i) (for-each (lambda (i)
(fetch-insert! t (list i))) (fetch-insert! t (list i)))
l) l)
(unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8))) (unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8)))
(error 'perms "bad: ~a" l)) (error 'perms "bad: ~a" l))
(for-each (lambda (i) (for-each (lambda (i)
(fetch-delete! t i)) (fetch-delete! t i))
l) l)
(unless (equal? (fetch-tree->list t) '()) (unless (equal? (fetch-tree->list t) '())
(error 'perms "remove bad: ~a" l)))) (error 'perms "remove bad: ~a" l))))
perms) perms)
|# |#

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

@ -32,142 +32,142 @@
(import) (import)
(export qp^) (export qp^)
;; Exceptions: ;; Exceptions:
;; String or input-port expected: ;; String or input-port expected:
(define-struct qp-error ()) (define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ()) (define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size)) (define-struct (qp-wrong-line-size qp-error) (size))
;; qp-encode : bytes -> bytes ;; qp-encode : bytes -> bytes
;; 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))))
;; qp-decode : string -> string ;; qp-decode : string -> string
;; 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)
(when #f (when #f
(fprintf (current-error-port) (fprintf (current-error-port)
(apply format msg args)) (apply format msg args))
(newline (current-error-port))))) (newline (current-error-port)))))
(define (hex-digit? i) (define (hex-digit? i)
(vector-ref hex-values i)) (vector-ref hex-values i))
(define hex-bytes->byte (define hex-bytes->byte
(lambda (b1 b2) (lambda (b1 b2)
(+ (* 16 (vector-ref hex-values b1)) (+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2)))) (vector-ref hex-values b2))))
(define write-hex-bytes (define write-hex-bytes
(lambda (byte p) (lambda (byte p)
(write-byte 61 p) (write-byte 61 p)
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p) (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))) (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
(define re:blanks #rx#"[ \t]+$") (define re:blanks #rx#"[ \t]+$")
(define qp-encode-stream (define qp-encode-stream
(opt-lambda (in out [newline-string #"\n"]) (opt-lambda (in out [newline-string #"\n"])
(let loop ([col 0]) (let loop ([col 0])
(if (= col 75) (if (= col 75)
(begin (begin
;; Soft newline: ;; Soft newline:
(write-byte 61 out) (write-byte 61 out)
(display newline-string out) (display newline-string out)
(loop 0)) (loop 0))
(let ([i (read-byte in)]) (let ([i (read-byte in)])
(cond (cond
[(eof-object? i) (void)] [(eof-object? i) (void)]
[(or (= i 10) (= i 13)) [(or (= i 10) (= i 13))
(write-byte i out) (write-byte i out)
(loop 0)] (loop 0)]
[(or (<= 33 i 60) (<= 62 i 126) [(or (<= 33 i 60) (<= 62 i 126)
(and (or (= i 32) (= i 9)) (and (or (= i 32) (= i 9))
(not (let ([next (peek-byte in)]) (not (let ([next (peek-byte in)])
(or (eof-object? next) (= next 10) (= next 13)))))) (or (eof-object? next) (= next 10) (= next 13))))))
;; single-byte mode: ;; single-byte mode:
(write-byte i out) (write-byte i out)
(loop (add1 col))] (loop (add1 col))]
[(>= col 73) [(>= col 73)
;; need a soft newline first ;; need a soft newline first
(write-byte 61 out) (write-byte 61 out)
(display newline-string out) (display newline-string out)
;; now the octect ;; now the octect
(write-hex-bytes i out) (write-hex-bytes i out)
(loop 3)] (loop 3)]
[else [else
;; an octect ;; an octect
(write-hex-bytes i out) (write-hex-bytes i out)
(loop (+ col 3))])))))) (loop (+ col 3))]))))))
;; Tables ;; Tables
(define hex-values (make-vector 256 #f)) (define hex-values (make-vector 256 #f))
(define hex-bytes (make-vector 16)) (define hex-bytes (make-vector 16))
(let loop ([i 0]) (let loop ([i 0])
(unless (= i 10) (unless (= i 10)
(vector-set! hex-values (+ i 48) i) (vector-set! hex-values (+ i 48) i)
(vector-set! hex-bytes i (+ i 48)) (vector-set! hex-bytes i (+ i 48))
(loop (add1 i)))) (loop (add1 i))))
(let loop ([i 0]) (let loop ([i 0])
(unless (= i 6) (unless (= i 6)
(vector-set! hex-values (+ i 65) (+ 10 i)) (vector-set! hex-values (+ i 65) (+ 10 i))
(vector-set! hex-values (+ i 97) (+ 10 i)) (vector-set! hex-values (+ i 97) (+ 10 i))
(vector-set! hex-bytes (+ 10 i) (+ i 65)) (vector-set! hex-bytes (+ 10 i) (+ i 65))
(loop (add1 i))))) (loop (add1 i)))))
;;; qp-unit.ss ends here ;;; qp-unit.ss ends here

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

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

@ -1,119 +1,118 @@
(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^)
(define-struct (no-mail-recipients exn) ()) (define-struct (no-mail-recipients exn) ())
(define sendmail-search-path (define sendmail-search-path
'("/usr/lib" "/usr/sbin")) '("/usr/lib" "/usr/sbin"))
(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
(loop (cdr paths)))))) (loop (cdr paths))))))
(raise (make-exn:fail:unsupported (raise (make-exn:fail:unsupported
"sendmail only available under Unix" "sendmail only available under Unix"
(current-continuation-marks))))) (current-continuation-marks)))))
;; send-mail-message/port : ;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string) ;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport ;; [x list (string)] -> oport
;; -- sender can be anything, though spoofing is not recommended. ;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that ;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other ;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely ;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on ;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text ;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete. ;; has been written, so that the sendmail process can complete.
(define send-mail-message/port (define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients (lambda (sender subject to-recipients cc-recipients bcc-recipients
. other-headers) . other-headers)
(when (and (null? to-recipients) (null? cc-recipients) (when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients)) (null? bcc-recipients))
(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)))
(begin (begin
(fprintf writer (fprintf writer
(if (null? rest) (if (null? rest)
"~a " "~a "
"~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))
other-headers) other-headers)
(newline writer) (newline writer)
writer)))) writer))))
;; send-mail-message : ;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x ;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> () ;; list (string) [x list (string)] -> ()
;; -- sender can be anything, though spoofing is not recommended. The ;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected ;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow ;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are ;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already. ;; expected to be completely formatted already.
(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))
text) text)
(close-output-port writer))))) (close-output-port 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@)

154
collects/net/sendurl.ss
View File

@ -28,77 +28,77 @@
(opt-lambda (url-str [separate-window? separate-by-default?]) (opt-lambda (url-str [separate-window? separate-by-default?])
(cond (cond
[(procedure? (external-browser)) [(procedure? (external-browser))
((external-browser) url-str)] ((external-browser) url-str)]
[(eq? (system-type) 'macos) [(eq? (system-type) 'macos)
(if (regexp-match "Blue Box" (system-type 'machine)) (if (regexp-match "Blue Box" (system-type 'machine))
;; Classic inside OS X: ;; Classic inside OS X:
(let loop ([l '("MSIE" "NAVG")]) (let loop ([l '("MSIE" "NAVG")])
(if (null? l) (if (null? l)
(error 'send-url "couldn't start Internet Explorer or Netscape") (error 'send-url "couldn't start Internet Explorer or Netscape")
(with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))]) (with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
(subprocess #f #f #f "by-id" (car l)) (subprocess #f #f #f "by-id" (car l))
(let loop ([retries 2]) ;; <<< Yuck <<< (let loop ([retries 2]) ;; <<< Yuck <<<
(if (zero? retries) (if (zero? retries)
(error "enough already") ; caught above (error "enough already") ; caught above
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(loop (sub1 retries)))]) (loop (sub1 retries)))])
(let ([t (thread (lambda () (let ([t (thread (lambda ()
(send-event (car l) "GURL" "GURL" url-str)))]) (send-event (car l) "GURL" "GURL" url-str)))])
(sync/timeout 1 t) ;; <<< Yuck (timeout) <<< (sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
(when (thread-running? t) (when (thread-running? t)
(kill-thread t) (kill-thread t)
(error "timeout"))))))))) (error "timeout")))))))))
;; Normal OS Classic: ;; Normal OS Classic:
(send-event "MACS" "GURL" "GURL" url-str))] (send-event "MACS" "GURL" "GURL" url-str))]
[(or (eq? (system-type) 'macosx) [(or (eq? (system-type) 'macosx)
(equal? "ppc-darwin" (system-library-subpath))) (equal? "ppc-darwin" (system-library-subpath)))
;; not sure what changed, but this is wrong now.... -robby ;; not sure what changed, but this is wrong now.... -robby
;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25"))) ;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))] (browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
[(eq? (system-type) 'windows) [(eq? (system-type) 'windows)
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)] (shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
[(eq? (system-type) 'unix) [(eq? (system-type) 'unix)
(let ([preferred (or (external-browser) (get-preference 'external-browser))]) (let ([preferred (or (external-browser) (get-preference 'external-browser))])
(cond (cond
[(use-browser 'opera preferred) [(use-browser 'opera preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
;; opera may not return -- always open asyncronously ;; opera may not return -- always open asyncronously
;; opera starts a new browser automatically, if it can't find one ;; opera starts a new browser automatically, if it can't find one
(browser-process* browser-path "-remote" (browser-process* browser-path "-remote"
(format "openURL(~a)" (format "openURL(~a)"
(if separate-window? (if separate-window?
(format "~a,new-window" url-str) (format "~a,new-window" url-str)
url-str))))] url-str))))]
[(use-browser 'galeon preferred) [(use-browser 'galeon preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
(browser-process* browser-path (browser-process* browser-path
(if separate-window? "-w" "-x") (if separate-window? "-w" "-x")
url-str))] url-str))]
[(or (use-browser 'netscape preferred) [(or (use-browser 'netscape preferred)
(use-browser 'mozilla preferred)) (use-browser 'mozilla preferred))
=> =>
(lambda (browser-path) (lambda (browser-path)
;; netscape's -remote returns with an error code, if no ;; netscape's -remote returns with an error code, if no
;; netscape is around. start a new netscape in that case. ;; netscape is around. start a new netscape in that case.
(or (system* browser-path "-remote" (or (system* browser-path "-remote"
(format "openURL(~a)" (format "openURL(~a)"
(if separate-window? (if separate-window?
(format "~a,new-window" url-str) (format "~a,new-window" url-str)
url-str))) url-str)))
(browser-process* browser-path url-str)))] (browser-process* browser-path url-str)))]
[(use-browser 'dillo preferred) [(use-browser 'dillo preferred)
=> =>
(lambda (browser-path) (lambda (browser-path)
(browser-process* browser-path url-str))] (browser-process* browser-path url-str))]
[(custom-browser? preferred) [(custom-browser? preferred)
(let ([cmd (string-append (car preferred) (let ([cmd (string-append (car preferred)
url-str url-str
(cdr preferred))]) (cdr preferred))])
(browser-process cmd))] (browser-process cmd))]
[else [else
(error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))] (error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
[else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))]))) [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
; : tst -> bool ; : tst -> bool
@ -122,22 +122,22 @@
; to find the path for the named browser, unless another browser is preferred ; to find the path for the named browser, unless another browser is preferred
(define (use-browser browser-name preferred) (define (use-browser browser-name preferred)
(and (or (not preferred) (and (or (not preferred)
(eq? preferred browser-name)) (eq? preferred browser-name))
(find-executable-path (symbol->string browser-name) #f))) (find-executable-path (symbol->string browser-name) #f)))
;; run-browser : process-proc list-of-strings -> void ;; run-browser : process-proc list-of-strings -> void
(define (run-browser process*/ports args) (define (run-browser process*/ports args)
(let-values ([(stdout stdin pid stderr control) (let-values ([(stdout stdin pid stderr control)
(apply values (apply process*/ports (apply values (apply process*/ports
(open-output-nowhere) (open-output-nowhere)
#f #f
(current-error-port) (current-error-port)
args))]) args))])
(close-output-port stdin) (close-output-port stdin)
(thread (lambda () (thread (lambda ()
(control 'wait) (control 'wait)
(when (eq? 'done-error (control 'status)) (when (eq? 'done-error (control 'status))
(error 'run-browser "process execute failed: ~e" args)))) (error 'run-browser "process execute failed: ~e" args))))
(void))) (void)))
(define (browser-process* . args) (define (browser-process* . args)

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)

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

@ -1,131 +1,127 @@
(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^)
(define smtp-sending-server (make-parameter "localhost")) (define smtp-sending-server (make-parameter "localhost"))
(define debug-via-stdio? #f) (define debug-via-stdio? #f)
(define crlf (string #\return #\linefeed)) (define crlf (string #\return #\linefeed))
(define (log . args) (define (log . args)
;; (apply printf args) ;; (apply printf args)
(void)) (void))
(define (starts-with? l n) (define (starts-with? l n)
(and (>= (string-length l) (string-length n)) (and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n))))) (string=? n (substring l 0 (string-length n)))))
(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))]) (if (eof-object? l)
(log "server: ~a~n" l) (error 'check-reply "got EOF")
(if (eof-object? l) (let ([n (number->string v)])
(error 'check-reply "got EOF") (unless (starts-with? l n)
(let ([n (number->string v)]) (error 'check-reply "expected reply ~a; got: ~a" v l))
(unless (starts-with? l n) (let ([n- (string-append n "-")])
(error 'check-reply "expected reply ~a; got: ~a" v l)) (when (starts-with? l n-)
(let ([n- (string-append n "-")]) ;; Multi-line reply. Go again.
(when (starts-with? l n-) (check-reply r v w)))))))
;; Multi-line reply. Go again.
(check-reply r v w)))))))
(define (protect-line l) (define (protect-line l)
;; If begins with a dot, add one more ;; If begins with a dot, add one more
(if (or (equal? l #"") (if (or (equal? l #"")
(equal? l "") (equal? l "")
(and (string? l) (and (string? l)
(not (char=? #\. (string-ref l 0)))) (not (char=? #\. (string-ref l 0))))
(and (bytes? l) (and (bytes? l)
(not (= (char->integer #\.) (bytes-ref l 0))))) (not (= (char->integer #\.) (bytes-ref l 0)))))
l l
(if (bytes? l) (if (bytes? l)
(bytes-append #"." l) (bytes-append #"." l)
(string-append "." l)))) (string-append "." l))))
(define smtp-sending-end-of-message (define smtp-sending-end-of-message
(make-parameter void (make-parameter void
(lambda (f) (lambda (f)
(unless (and (procedure? f) (unless (and (procedure? f)
(procedure-arity-includes? f 0)) (procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f)) (raise-type-error 'smtp-sending-end-of-message "thunk" f))
f))) f)))
(define (smtp-send-message* r w sender recipients header message-lines (define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd) auth-user auth-passwd)
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(close-input-port r) (close-input-port r)
(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
(string->bytes/latin-1 (string->bytes/latin-1
(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)
(close-output-port w) (close-output-port w)
(close-input-port r))) (close-input-port r)))
(define smtp-send-message (define smtp-send-message
(lambda/kw (server sender recipients header message-lines (lambda/kw (server sender recipients header message-lines
#:key #:key
[port-no 25] [port-no 25]
[auth-user #f] [auth-user #f]
[auth-passwd #f] [auth-passwd #f]
[tcp-connect tcp-connect] [tcp-connect tcp-connect]
#:body #:body
(#:optional [opt-port-no port-no])) (#:optional [opt-port-no port-no]))
(when (null? recipients) (when (null? recipients)
(error 'send-smtp-message "no receivers")) (error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio? (let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port)) (values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))]) (tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd))))) auth-user auth-passwd)))))

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

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

@ -2,62 +2,62 @@
(provide make-ssl-tcp@) (provide make-ssl-tcp@)
(require (lib "unit.ss") (require (lib "unit.ss")
"tcp-sig.ss" "tcp-sig.ss"
(lib "mzssl.ss" "openssl") (lib "mzssl.ss" "openssl")
(lib "etc.ss")) (lib "etc.ss"))
(define (make-ssl-tcp@ (define (make-ssl-tcp@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
client-cert-file client-key-file client-root-cert-files) client-cert-file client-key-file client-root-cert-files)
(unit (unit
(import) (import)
(export tcp^) (export tcp^)
(define ctx (ssl-make-client-context)) (define ctx (ssl-make-client-context))
(when client-cert-file (when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file)) (ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file (when client-key-file
(ssl-load-private-key! ctx client-key-file)) (ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files (when client-root-cert-files
(ssl-set-verify! ctx #t) (ssl-set-verify! ctx #t)
(map (lambda (f) (map (lambda (f)
(ssl-load-verify-root-certificates! ctx f)) (ssl-load-verify-root-certificates! ctx f))
client-root-cert-files)) client-root-cert-files))
(define (tcp-abandon-port p) (define (tcp-abandon-port p)
(if (input-port? p) (if (input-port? p)
(close-input-port p) (close-input-port p)
(close-output-port p))) (close-output-port p)))
(define tcp-accept ssl-accept) (define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break) (define tcp-accept/enable-break ssl-accept/enable-break)
;; accept-ready? doesn't really work for SSL: ;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p) (define (tcp-accept-ready? p)
#f) #f)
(define tcp-addresses ssl-addresses) (define tcp-addresses ssl-addresses)
(define tcp-close ssl-close) (define tcp-close ssl-close)
(define tcp-connect (define tcp-connect
(opt-lambda (hostname port-k) (opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx))) (ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break (define tcp-connect/enable-break
(opt-lambda (hostname port-k) (opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx))) (ssl-connect/enable-break hostname port-k ctx)))
(define tcp-listen (define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f]) (opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)]) (let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file (when server-cert-file
(ssl-load-certificate-chain! l server-cert-file)) (ssl-load-certificate-chain! l server-cert-file))
(when server-key-file (when server-key-file
(ssl-load-private-key! l server-key-file)) (ssl-load-private-key! l server-key-file))
(when server-root-cert-files (when server-root-cert-files
(ssl-set-verify! l #t) (ssl-set-verify! l #t)
(map (lambda (f) (map (lambda (f)
(ssl-load-verify-root-certificates! l f)) (ssl-load-verify-root-certificates! l f))
server-root-cert-files)) server-root-cert-files))
(when server-suggest-auth-file (when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file)) (ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l))) l)))
(define tcp-listener? ssl-listener?)))) (define tcp-listener? ssl-listener?))))

20
collects/net/tcp-sig.ss
View File

@ -1,11 +1,11 @@
(module tcp-sig (lib "a-signature.ss") (module tcp-sig (lib "a-signature.ss")
tcp-abandon-port tcp-abandon-port
tcp-accept tcp-accept
tcp-accept/enable-break tcp-accept/enable-break
tcp-accept-ready? tcp-accept-ready?
tcp-addresses tcp-addresses
tcp-close tcp-close
tcp-connect tcp-connect
tcp-connect/enable-break tcp-connect/enable-break
tcp-listen tcp-listen
tcp-listener?) tcp-listener?)

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

153
collects/net/unihead.ss
View File

@ -1,53 +1,53 @@
(module unihead mzscheme (module unihead mzscheme
(require (lib "base64.ss" "net") (require (lib "base64.ss" "net")
(lib "qp.ss" "net") (lib "qp.ss" "net")
(lib "string.ss")) (lib "string.ss"))
(provide encode-for-header (provide encode-for-header
decode-for-header decode-for-header
generalize-encoding) generalize-encoding)
(define re:ascii #rx"^[\u0-\u7F]*$") (define re:ascii #rx"^[\u0-\u7F]*$")
(define (encode-for-header s) (define (encode-for-header s)
(if (regexp-match? re:ascii s) (if (regexp-match? re:ascii s)
s s
(let ([l (regexp-split #rx"\r\n" s)]) (let ([l (regexp-split #rx"\r\n" s)])
(apply string-append (apply string-append
(map encode-line-for-header l))))) (map encode-line-for-header l)))))
(define (encode-line-for-header s) (define (encode-line-for-header s)
(define (loop s string->bytes charset encode encoding) (define (loop s string->bytes charset encode encoding)
;; Find ASCII (and no "=") prefix before a space ;; Find ASCII (and no "=") prefix before a space
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)]) (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
(if m (if m
(string-append (string-append
(cadr m) (cadr m)
(loop (caddr m) string->bytes charset encode encoding)) (loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space ;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)]) (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m (if m
(string-append (string-append
(loop (cadr m) string->bytes charset encode encoding) (loop (cadr m) string->bytes charset encode encoding)
(caddr m)) (caddr m))
(format "=?~a?~a?~a?=" (format "=?~a?~a?~a?="
charset encoding charset encoding
(regexp-replace* #rx#"[\r\n]+$" (regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s)) (encode (string->bytes s))
#""))))))) #"")))))))
(cond (cond
[(regexp-match? re:ascii s) [(regexp-match? re:ascii s)
;; ASCII - do nothing ;; ASCII - do nothing
s] s]
[(regexp-match? #rx"[^\u0-\uFF]" s) [(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8 ;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")] (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else [else
;; use Latin-1 ;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1" (loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s) (lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_")) (regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")])) "Q")]))
;; ---------------------------------------- ;; ----------------------------------------
@ -73,45 +73,46 @@
(define (decode-for-header s) (define (decode-for-header s)
(and s (and s
(let ([m (regexp-match re:encoded (let ([m (regexp-match re:encoded
(string->bytes/latin-1 s (char->integer #\?)))]) (string->bytes/latin-1 s (char->integer #\?)))])
(if m (if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q")) (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling ;; quoted-printable, with special _ handling
(lambda (x) (lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" "))) (qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64: ;; base64:
base64-decode) base64-decode)
(cadddr (cdr m)))] (cadddr (cdr m)))]
[encoding (caddr m)]) [encoding (caddr m)])
(string-append (string-append
(decode-for-header (bytes->string/latin-1 (cadr m))) (decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)]) (let ([encoding (generalize-encoding encoding)])
(cond (cond
[(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)
(if c "UTF-8")])
(let-values ([(r got status) (if c
(bytes-convert c s)]) (let-values ([(r got status)
(bytes-close-converter c) (bytes-convert c s)])
(if (eq? status 'complete) (bytes-close-converter c)
(bytes->string/utf-8 r #\?) (if (eq? status 'complete)
(bytes->string/latin-1 s))) (bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))])) (bytes->string/latin-1 s)))
(let ([rest (cadddr (cddr m))]) (bytes->string/latin-1 s)))]))
(let ([rest (let ([rest (cadddr (cddr m))])
;; A CR-LF-space-encoding sequence means that we (let ([rest
;; should drop the space. ;; A CR-LF-space-encoding sequence means that we
(if (and (> (bytes-length rest) 4) ;; should drop the space.
(= 13 (bytes-ref rest 0)) (if (and (> (bytes-length rest) 4)
(= 10 (bytes-ref rest 1)) (= 13 (bytes-ref rest 0))
(= 32 (bytes-ref rest 2)) (= 10 (bytes-ref rest 1))
(let ([m (regexp-match-positions (= 32 (bytes-ref rest 2))
re:encoded rest)]) (let ([m (regexp-match-positions
(and m (= (caaddr m) 5)))) re:encoded rest)])
(subbytes rest 3) (and m (= (caaddr m) 5))))
rest)]) (subbytes rest 3)
(decode-for-header (bytes->string/latin-1 rest)))))) rest)])
s))))) (decode-for-header (bytes->string/latin-1 rest))))))
s)))))

338
collects/net/uri-codec-unit.ss
View File

@ -178,199 +178,199 @@ JALQefhDMCATcl2/bZL0bw==
(import) (import)
(export uri-codec^) (export uri-codec^)
(define (self-map-char ch) (cons ch ch)) (define (self-map-char ch) (cons ch ch))
(define (self-map-chars str) (map self-map-char (string->list str))) (define (self-map-chars str) (map self-map-char (string->list str)))
;; The characters that always map to themselves ;; The characters that always map to themselves
(define alphanumeric-mapping (define alphanumeric-mapping
(self-map-chars (self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; Characters that sometimes map to themselves ;; Characters that sometimes map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()")) (define safe-mapping (self-map-chars "-_.!~*'()"))
;; The strict URI mapping ;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-mapping)) (define uri-mapping (append alphanumeric-mapping safe-mapping))
;; The uri path segment mapping from RFC 3986 ;; The uri path segment mapping from RFC 3986
(define uri-path-segment-mapping (define uri-path-segment-mapping
(append alphanumeric-mapping (append alphanumeric-mapping
safe-mapping safe-mapping
(map (λ (c) (cons c c)) (string->list "@+,=$&:")))) (map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
;; The form-urlencoded mapping ;; The form-urlencoded mapping
(define form-urlencoded-mapping (define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping)) `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
(define (number->hex-string number) (define (number->hex-string number)
(define (hex n) (string-ref "0123456789ABCDEF" n)) (define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16)))) (string #\% (hex (quotient number 16)) (hex (modulo number 16))))
(define (hex-string->number hex-string) (define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16)) (string->number (substring hex-string 1 3) 16))
(define ascii-size 128) (define ascii-size 128)
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string)) ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(define (make-codec-tables alist) (define (make-codec-tables alist)
(let ([encoding-table (build-vector ascii-size number->hex-string)] (let ([encoding-table (build-vector ascii-size number->hex-string)]
[decoding-table (build-vector ascii-size values)]) [decoding-table (build-vector ascii-size values)])
(for-each (match-lambda (for-each (match-lambda
[(orig . enc) [(orig . enc)
(vector-set! encoding-table (vector-set! encoding-table
(char->integer orig) (char->integer orig)
(string enc)) (string enc))
(vector-set! decoding-table (vector-set! decoding-table
(char->integer enc) (char->integer enc)
(char->integer orig))]) (char->integer orig))])
alist) alist)
(values encoding-table decoding-table))) (values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector) (define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping)) (make-codec-tables uri-mapping))
(define-values (uri-path-segment-encoding-vector (define-values (uri-path-segment-encoding-vector
uri-path-segment-decoding-vector) uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping)) (make-codec-tables uri-path-segment-mapping))
(define-values (form-urlencoded-encoding-vector (define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector) form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping)) (make-codec-tables form-urlencoded-mapping))
;; vector string -> string ;; vector string -> string
(define (encode table str) (define (encode table str)
(apply string-append (apply string-append
(map (lambda (byte) (map (lambda (byte)
(cond (cond
[(< byte ascii-size) [(< byte ascii-size)
(vector-ref table byte)] (vector-ref table byte)]
[else (number->hex-string byte)])) [else (number->hex-string byte)]))
(bytes->list (string->bytes/utf-8 str))))) (bytes->list (string->bytes/utf-8 str)))))
;; vector string -> string ;; vector string -> string
(define (decode table str) (define (decode table str)
(define internal-decode (define internal-decode
(match-lambda (match-lambda
[() (list)] [() (list)]
[(#\% (? hex-digit? char1) (? hex-digit? char2) . rest) [(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
;; This used to consult the table again, but I think that's ;; This used to consult the table again, but I think that's
;; wrong. For example %2b should produce +, not a space. ;; wrong. For example %2b should produce +, not a space.
(cons (string->number (string char1 char2) 16) (cons (string->number (string char1 char2) 16)
(internal-decode rest))] (internal-decode rest))]
[((? ascii-char? char) . rest) [((? ascii-char? char) . rest)
(cons (cons
(vector-ref table (char->integer char)) (vector-ref table (char->integer char))
(internal-decode rest))] (internal-decode rest))]
[(char . rest) [(char . rest)
(append (append
(bytes->list (string->bytes/utf-8 (string char))) (bytes->list (string->bytes/utf-8 (string char)))
(internal-decode rest))])) (internal-decode rest))]))
(bytes->string/utf-8 (bytes->string/utf-8
(apply bytes (internal-decode (string->list str))))) (apply bytes (internal-decode (string->list str)))))
(define (ascii-char? c) (define (ascii-char? c)
(< (char->integer c) ascii-size)) (< (char->integer c) ascii-size))
(define (hex-digit? c) (define (hex-digit? c)
(or (char<=? #\0 c #\9) (or (char<=? #\0 c #\9)
(char<=? #\a c #\f) (char<=? #\a c #\f)
(char<=? #\A c #\F))) (char<=? #\A c #\F)))
;; string -> string ;; string -> string
(define (uri-encode str) (define (uri-encode str)
(encode uri-encoding-vector str)) (encode uri-encoding-vector str))
;; string -> string ;; string -> string
(define (uri-decode str) (define (uri-decode str)
(decode uri-decoding-vector str)) (decode uri-decoding-vector str))
;; string -> string ;; string -> string
(define (uri-path-segment-encode str) (define (uri-path-segment-encode str)
(encode uri-path-segment-encoding-vector str)) (encode uri-path-segment-encoding-vector str))
;; string -> string ;; string -> string
(define (uri-path-segment-decode str) (define (uri-path-segment-decode str)
(decode uri-path-segment-decoding-vector str)) (decode uri-path-segment-decoding-vector str))
;; string -> string ;; string -> string
(define (form-urlencoded-encode str) (define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str)) (encode form-urlencoded-encoding-vector str))
;; string -> string ;; string -> string
(define (form-urlencoded-decode str) (define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str)) (decode form-urlencoded-decoding-vector str))
;; listof (cons string string) -> string ;; listof (cons string string) -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
;; listof (cons symbol string) -> string ;; listof (cons symbol string) -> string
(define (alist->form-urlencoded args) (define (alist->form-urlencoded args)
(let* ([mode (current-alist-separator-mode)] (let* ([mode (current-alist-separator-mode)]
[format-one [format-one
(lambda (arg) (lambda (arg)
(let* ([name (car arg)] (let* ([name (car arg)]
[value (cdr arg)]) [value (cdr arg)])
(string-append (form-urlencoded-encode (symbol->string name)) (string-append (form-urlencoded-encode (symbol->string name))
"=" "="
(form-urlencoded-encode value))))] (form-urlencoded-encode value))))]
[strs (let loop ([args args]) [strs (let loop ([args args])
(cond (cond
[(null? args) null] [(null? args) null]
[(null? (cdr args)) (list (format-one (car args)))] [(null? (cdr args)) (list (format-one (car args)))]
[else (list* (format-one (car args)) [else (list* (format-one (car args))
(if (eq? mode 'amp) "&" ";") (if (eq? mode 'amp) "&" ";")
(loop (cdr args)))]))]) (loop (cdr args)))]))])
(apply string-append strs))) (apply string-append strs)))
;; string -> listof (cons string string) ;; string -> listof (cons string string)
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
(define (form-urlencoded->alist str) (define (form-urlencoded->alist str)
(define key-regexp #rx"[^=]*") (define key-regexp #rx"[^=]*")
(define value-regexp (case (current-alist-separator-mode) (define value-regexp (case (current-alist-separator-mode)
[(semi) #rx"[^;]*"] [(semi) #rx"[^;]*"]
[(amp) #rx"[^&]*"] [(amp) #rx"[^&]*"]
[else #rx"[^&;]*"])) [else #rx"[^&;]*"]))
(define (next-key str start) (define (next-key str start)
(and (< start (string-length str)) (and (< start (string-length str))
(match (regexp-match-positions key-regexp str start) (match (regexp-match-positions key-regexp str start)
[((start . end)) [((start . end))
(vector (let ([s (form-urlencoded-decode (vector (let ([s (form-urlencoded-decode
(substring str start end))]) (substring str start end))])
(string->symbol s)) (string->symbol s))
(add1 end))] (add1 end))]
[#f #f]))) [#f #f])))
(define (next-value str start) (define (next-value str start)
(and (< start (string-length str)) (and (< start (string-length str))
(match (regexp-match-positions value-regexp str start) (match (regexp-match-positions value-regexp str start)
[((start . end)) [((start . end))
(vector (form-urlencoded-decode (substring str start end)) (vector (form-urlencoded-decode (substring str start end))
(add1 end))] (add1 end))]
[#f #f]))) [#f #f])))
(define (next-pair str start) (define (next-pair str start)
(match (next-key str start) (match (next-key str start)
[#(key start) [#(key start)
(match (next-value str start) (match (next-value str start)
[#(value start) [#(value start)
(vector (cons key value) start)] (vector (cons key value) start)]
[#f [#f
(vector (cons key "") (string-length str))])] (vector (cons key "") (string-length str))])]
[#f #f])) [#f #f]))
(let loop ([start 0] (let loop ([start 0]
[end (string-length str)] [end (string-length str)]
[make-alist (lambda (x) x)]) [make-alist (lambda (x) x)])
(if (>= start end) (if (>= start end)
(make-alist '()) (make-alist '())
(match (next-pair str start) (match (next-pair str start)
[#(pair next-start) [#(pair next-start)
(loop next-start end (lambda (x) (make-alist (cons pair x))))] (loop next-start end (lambda (x) (make-alist (cons pair x))))]
[#f (make-alist '())])))) [#f (make-alist '())]))))
(define current-alist-separator-mode (define current-alist-separator-mode
(make-parameter 'amp-or-semi (make-parameter 'amp-or-semi
(lambda (s) (lambda (s)
(unless (memq s '(amp semi amp-or-semi)) (unless (memq s '(amp semi amp-or-semi))
(raise-type-error 'current-alist-separator-mode (raise-type-error 'current-alist-separator-mode
"'amp, 'semi, or 'amp-or-semi" "'amp, 'semi, or 'amp-or-semi"
s)) s))
s)))) s))))
;;; uri-codec-unit.ss ends here ;;; uri-codec-unit.ss ends here

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)

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

@ -30,419 +30,418 @@
(import tcp^) (import tcp^)
(export url^) (export url^)
(define-struct (url-exception exn:fail) ()) (define-struct (url-exception exn:fail) ())
(define current-proxy-servers (define current-proxy-servers
(make-parameter null (make-parameter null
(lambda (v) (lambda (v)
(unless (and (list? v) (unless (and (list? v)
(andmap (andmap
(lambda (v) (lambda (v)
(and (list? v) (and (list? v)
(= 3 (length v)) (= 3 (length v))
(equal? (car v) "http") (equal? (car v) "http")
(string? (car v)) (string? (car v))
(number? (caddr v)) (number? (caddr v))
(exact? (caddr v)) (exact? (caddr v))
(integer? (caddr v)) (integer? (caddr v))
(<= 1 (caddr v) 65535))) (<= 1 (caddr v) 65535)))
v)) v))
(raise-type-error (raise-type-error
'current-proxy-servers 'current-proxy-servers
"list of list of scheme, string, and exact integer in [1,65535]" "list of list of scheme, string, and exact integer in [1,65535]"
v)) v))
(apply (apply
list-immutable list-immutable
(map (lambda (v) (map (lambda (v)
(list-immutable (string->immutable-string (car v)) (list-immutable (string->immutable-string (car v))
(string->immutable-string (cadr v)) (string->immutable-string (cadr v))
(caddr v))) (caddr v)))
v))))) v)))))
(define (url-error fmt . args) (define (url-error fmt . args)
(let ([s (string->immutable-string (let ([s (string->immutable-string
(apply format fmt (apply format fmt
(map (lambda (arg) (map (lambda (arg)
(if (url? arg) (url->string arg) arg)) (if (url? arg) (url->string arg) arg))
args)))]) args)))])
(raise (make-url-exception s (current-continuation-marks))))) (raise (make-url-exception s (current-continuation-marks)))))
(define (url->string url) (define (url->string url)
(let ([scheme (url-scheme url)] (let ([scheme (url-scheme url)]
[user (url-user url)] [user (url-user url)]
[host (url-host url)] [host (url-host url)]
[port (url-port url)] [port (url-port url)]
[path (url-path url)] [path (url-path url)]
[query (url-query url)] [query (url-query url)]
[fragment (url-fragment url)] [fragment (url-fragment url)]
[sa string-append]) [sa string-append])
(sa (if scheme (sa scheme ":") "") (sa (if scheme (sa scheme ":") "")
(if (or user host port) (if (or user host port)
(sa "//" (sa "//"
(if user (sa (uri-encode user) "@") "") (if user (sa (uri-encode user) "@") "")
(if host host "") (if host host "")
(if port (sa ":" (number->string port)) "") (if port (sa ":" (number->string port)) "")
;; There used to be a "/" here, but that causes an ;; There used to be a "/" here, but that causes an
;; extra leading slash -- wonder why it ever worked! ;; extra leading slash -- wonder why it ever worked!
) )
"") "")
(combine-path-strings (url-path-absolute? url) path) (combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "") ;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query))) (if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) "")))) (if fragment (sa "#" (uri-encode fragment)) ""))))
;; url->default-port : url -> num ;; url->default-port : url -> num
(define (url->default-port url) (define (url->default-port url)
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) 80] (cond [(not scheme) 80]
[(string=? scheme "http") 80] [(string=? scheme "http") 80]
[(string=? scheme "https") 443] [(string=? scheme "https") 443]
[else (url-error "Scheme ~a not supported" (url-scheme url))]))) [else (url-error "Scheme ~a not supported" (url-scheme url))])))
;; make-ports : url -> in-port x out-port ;; make-ports : url -> in-port x out-port
(define (make-ports url proxy) (define (make-ports url proxy)
(let ([port-number (if proxy (let ([port-number (if proxy
(caddr proxy) (caddr proxy)
(or (url-port url) (url->default-port url)))] (or (url-port url) (url->default-port url)))]
[host (if proxy [host (if proxy
(cadr proxy) (cadr proxy)
(url-host url))]) (url-host url))])
(tcp-connect host port-number))) (tcp-connect host port-number)))
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings) (define (http://getpost-impure-port get? url post-data strings)
(let*-values (let*-values
([(proxy) (assoc (url-scheme url) (current-proxy-servers))] ([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)] [(server->client client->server) (make-ports url proxy)]
[(access-string) (url->string [(access-string) (url->string
(if proxy (if proxy
url url
(make-url #f #f #f #f (make-url #f #f #f #f
(url-path-absolute? url) (url-path-absolute? url)
(url-path url) (url-path url)
(url-query url) (url-query url)
(url-fragment url))))]) (url-fragment url))))])
(define (println . xs) (define (println . xs)
(for-each (lambda (x) (display x client->server)) xs) (for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server)) (display "\r\n" client->server))
(println (if get? "GET " "POST ") access-string " HTTP/1.0") (println (if get? "GET " "POST ") access-string " HTTP/1.0")
(println "Host: " (url-host url) (println "Host: " (url-host url)
(let ([p (url-port url)]) (if p (format ":~a" p) ""))) (let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when post-data (println "Content-Length: " (bytes-length post-data))) (when post-data (println "Content-Length: " (bytes-length post-data)))
(for-each println strings) (for-each println strings)
(println) (println)
(when post-data (display post-data client->server)) (when post-data (display post-data client->server))
(flush-output client->server) (flush-output client->server)
(tcp-abandon-port client->server) (tcp-abandon-port client->server)
server->client)) server->client))
(define (file://->path url) (define (file://->path url)
;; remove all ""s ;; remove all ""s
(let ([elts (remove* '("") (map path/param-path (url-path url)))] (let ([elts (remove* '("") (map path/param-path (url-path url)))]
[abs? (url-path-absolute? url)]) [abs? (url-path-absolute? url)])
;; See the discussion in PR8060 for an explanation ;; See the discussion in PR8060 for an explanation
(if (eq? 'windows url:os-type) (if (eq? 'windows url:os-type)
(let ([host (or (url-host url) "")]) (let ([host (or (url-host url) "")])
(unless (equal? "" host) (set! elts (cons host elts))) (unless (equal? "" host) (set! elts (cons host elts)))
(if (null? elts) (if (null? elts)
(build-path) ; make it throw the error (build-path) ; make it throw the error
(let* ([fst (car elts)] [len (string-length fst)]) (let* ([fst (car elts)] [len (string-length fst)])
(if (or (not abs?) (eq? #\: (string-ref fst (sub1 len)))) (if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
(apply build-path elts) (apply build-path elts)
(if (null? (cdr elts)) (if (null? (cdr elts))
(build-path (string-append "\\\\" (car elts))) (build-path (string-append "\\\\" (car elts)))
(apply build-path (apply build-path
(string-append "\\\\" (car elts) "\\" (cadr elts)) (string-append "\\\\" (car elts) "\\" (cadr elts))
(cddr elts))))))) (cddr elts)))))))
(apply build-path (if abs? (cons "/" elts) elts))))) (apply build-path (if abs? (cons "/" elts) elts)))))
;; file://get-pure-port : url -> in-port ;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url) (define (file://get-pure-port url)
(open-input-file (file://->path url))) (open-input-file (file://->path url)))
(define (schemeless-url url) (define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
;; getpost-impure-port : bool x url x list (str) -> in-port ;; getpost-impure-port : bool x url x list (str) -> in-port
(define (getpost-impure-port get? url post-data strings) (define (getpost-impure-port get? url post-data strings)
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") [(or (string=? scheme "http")
(string=? scheme "https")) (string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)] (http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file") [(string=? scheme "file")
(url-error "There are no impure file: ports")] (url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)]))) [else (url-error "Scheme ~a unsupported" scheme)])))
;; get-impure-port : url [x list (str)] -> in-port ;; get-impure-port : url [x list (str)] -> in-port
(define get-impure-port (define get-impure-port
(case-lambda (case-lambda
[(url) (get-impure-port url '())] [(url) (get-impure-port url '())]
[(url strings) (getpost-impure-port #t url #f strings)])) [(url strings) (getpost-impure-port #t url #f strings)]))
;; post-impure-port : url x bytes [x list (str)] -> in-port ;; post-impure-port : url x bytes [x list (str)] -> in-port
(define post-impure-port (define post-impure-port
(case-lambda (case-lambda
[(url post-data) (post-impure-port url post-data '())] [(url post-data) (post-impure-port url post-data '())]
[(url post-data strings) [(url post-data strings)
(getpost-impure-port #f url post-data strings)])) (getpost-impure-port #f url post-data strings)]))
;; getpost-pure-port : bool x url x list (str) -> in-port ;; getpost-pure-port : bool x url x list (str) -> in-port
(define (getpost-pure-port get? url post-data strings) (define (getpost-pure-port get? url post-data strings)
(let ([scheme (url-scheme url)]) (let ([scheme (url-scheme url)])
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") [(or (string=? scheme "http")
(string=? scheme "https")) (string=? scheme "https"))
(let ([port (http://getpost-impure-port (let ([port (http://getpost-impure-port
get? url post-data strings)]) get? url post-data strings)])
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(close-input-port port) (close-input-port port)
(raise exn))]) (raise exn))])
(purify-port port)) (purify-port port))
port)] port)]
[(string=? scheme "file") [(string=? scheme "file")
(file://get-pure-port url)] (file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)]))) [else (url-error "Scheme ~a unsupported" scheme)])))
;; get-pure-port : url [x list (str)] -> in-port ;; get-pure-port : url [x list (str)] -> in-port
(define get-pure-port (define get-pure-port
(case-lambda (case-lambda
[(url) (get-pure-port url '())] [(url) (get-pure-port url '())]
[(url strings) (getpost-pure-port #t url #f strings)])) [(url strings) (getpost-pure-port #t url #f strings)]))
;; post-pure-port : url bytes [x list (str)] -> in-port ;; post-pure-port : url bytes [x list (str)] -> in-port
(define post-pure-port (define post-pure-port
(case-lambda (case-lambda
[(url post-data) (post-pure-port url post-data '())] [(url post-data) (post-pure-port url post-data '())]
[(url post-data strings) (getpost-pure-port #f url post-data strings)])) [(url post-data strings) (getpost-pure-port #f url post-data strings)]))
;; display-pure-port : in-port -> () ;; display-pure-port : in-port -> ()
(define (display-pure-port server->client) (define (display-pure-port server->client)
(copy-port server->client (current-output-port)) (copy-port server->client (current-output-port))
(close-input-port server->client)) (close-input-port server->client))
(define (empty-url? url) (define (empty-url? url)
(and (not (url-scheme url)) (and (not (url-scheme url))
(not (url-query url)) (not (url-query url))
(not (url-fragment url)) (not (url-fragment url))
(null? (url-path url)))) (null? (url-path url))))
;; transliteration of code in rfc 3986, section 5.2.2 ;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string) (define (combine-url/relative Base string)
(let ([R (string->url string)] (let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)]) [T (make-url #f #f #f #f #f '() '() #f)])
(if (url-scheme R) (if (url-scheme R)
(begin (begin
(set-url-scheme! T (url-scheme R)) (set-url-scheme! T (url-scheme R))
(set-url-user! T (url-user R)) ;; authority (set-url-user! T (url-user R)) ;; authority
(set-url-host! T (url-host R)) ;; authority (set-url-host! T (url-host R)) ;; authority
(set-url-port! T (url-port R)) ;; authority (set-url-port! T (url-port R)) ;; authority
(set-url-path-absolute?! T (url-path-absolute? R)) (set-url-path-absolute?! T (url-path-absolute? R))
(set-url-path! T (remove-dot-segments (url-path R))) (set-url-path! T (remove-dot-segments (url-path R)))
(set-url-query! T (url-query R))) (set-url-query! T (url-query R)))
(begin (begin
(if (url-host R) ;; => authority is defined (if (url-host R) ;; => authority is defined
(begin
(set-url-user! T (url-user R)) ;; authority
(set-url-host! T (url-host R)) ;; authority
(set-url-port! T (url-port R)) ;; authority
(set-url-path-absolute?! T (url-path-absolute? R))
(set-url-path! T (remove-dot-segments (url-path R)))
(set-url-query! T (url-query R)))
(begin
(if (null? (url-path R)) ;; => R has empty path
(begin
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (url-path Base))
(if (not (null? (url-query R)))
(set-url-query! T (url-query R))
(set-url-query! T (url-query Base))))
(begin
(cond
[(url-path-absolute? R)
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[(and (null? (url-path Base))
(url-host Base))
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[else
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (remove-dot-segments
(append (all-but-last (url-path Base))
(url-path R))))])
(set-url-query! T (url-query R))))
(set-url-user! T (url-user Base)) ;; authority
(set-url-host! T (url-host Base)) ;; authority
(set-url-port! T (url-port Base)))) ;; authority
(set-url-scheme! T (url-scheme Base))))
(set-url-fragment! T (url-fragment R))
T))
(define (all-but-last lst)
(cond [(null? lst) null]
[(null? (cdr lst)) null]
[else (cons (car lst) (all-but-last (cdr lst)))]))
;; cribbed from 5.2.4 in rfc 3986
;; the strange cases 2 and 4 implicitly change urls
;; with paths segments "." and ".." at the end
;; into "./" and "../" respectively
(define (remove-dot-segments path)
(let loop ([path path]
[result '()])
(cond
[(null? path) (reverse result)]
[(and (eq? (path/param-path (car path)) 'same)
(null? (cdr path)))
(loop (cdr path)
(cons (make-path/param "" '()) result))]
[(eq? (path/param-path (car path)) 'same)
(loop (cdr path)
result)]
[(and (eq? (path/param-path (car path)) 'up)
(null? (cdr path))
(not (null? result)))
(loop (cdr path)
(cons (make-path/param "" '()) (cdr result)))]
[(and (eq? (path/param-path (car path)) 'up)
(not (null? result)))
(loop (cdr path) (cdr result))]
[(and (eq? (path/param-path (car path)) 'up)
(null? result))
;; when we go up too far, just drop the "up"s.
(loop (cdr path) result)]
[else
(loop (cdr path) (cons (car path) result))])))
;; call/input-url : url x (url -> in-port) x (in-port -> T)
;; [x list (str)] -> T
(define call/input-url
(let ([handle-port
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client))
(lambda () (close-input-port server->client))))])
(case-lambda
[(url getter handler)
(handle-port (getter url) handler)]
[(url getter handler params)
(handle-port (getter url params) handler)])))
;; purify-port : in-port -> header-string
(define (purify-port port)
(let ([m (regexp-match-peek-positions
#rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))" port)])
(if m
(read-string (cdar m) port)
"")))
(define character-set-size 256)
;; netscape/string->url : str -> url
(define (netscape/string->url string)
(let ([url (string->url string)])
(if (url-scheme url)
url
(if (string=? string "")
(url-error "Can't resolve empty string as URL")
(begin (begin
(set-url-scheme! url (set-url-user! T (url-user R)) ;; authority
(if (char=? (string-ref string 0) #\/) "file" "http")) (set-url-host! T (url-host R)) ;; authority
url))))) (set-url-port! T (url-port R)) ;; authority
(set-url-path-absolute?! T (url-path-absolute? R))
(set-url-path! T (remove-dot-segments (url-path R)))
(set-url-query! T (url-query R)))
(begin
(if (null? (url-path R)) ;; => R has empty path
(begin
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (url-path Base))
(if (not (null? (url-query R)))
(set-url-query! T (url-query R))
(set-url-query! T (url-query Base))))
(begin
(cond
[(url-path-absolute? R)
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[(and (null? (url-path Base))
(url-host Base))
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[else
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (remove-dot-segments
(append (all-but-last (url-path Base))
(url-path R))))])
(set-url-query! T (url-query R))))
(set-url-user! T (url-user Base)) ;; authority
(set-url-host! T (url-host Base)) ;; authority
(set-url-port! T (url-port Base)))) ;; authority
(set-url-scheme! T (url-scheme Base))))
(set-url-fragment! T (url-fragment R))
T))
;; string->url : str -> url (define (all-but-last lst)
;; New implementation, mostly provided by Neil Van Dyke (cond [(null? lst) null]
(define url-rx [(null? (cdr lst)) null]
(regexp (string-append [else (cons (car lst) (all-but-last (cdr lst)))]))
"^"
"[ \t\f\r\n]*"
"(?:" ; <A front-opt
"(?:([a-zA-Z]*):)?" ; =1 scheme-colon-opt
"(?:" ; <B slashslash-opt
"//"
"(?:([^:/@;?#]*)@)?" ; =2 user-at-opt
"([^:/@;?#]*)?" ; =3 host-opt
"(?::([0-9]*))?" ; =4 colon-port-opt
")?" ; >B slashslash-opt
")?" ; >A front-opt
"([^?#]*)" ; =5 path
"(?:\\?([^#]*))?" ; =6 question-query-opt
"(?:#(.*))?" ; =7 hash-fragment-opt
"[ \t\f\r\n]*"
"$")))
(define (string->url str)
(apply
(lambda (scheme user host port path query fragment)
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(when (and (equal? "" port) (equal? "file" scheme)
(eq? 'windows url:os-type))
(set! path (string-append host ":" path))
(set! host #f))
(let* ([user (uri-decode/maybe user)]
[port (and port (string->number port))]
[abs? (and (not (= 0 (string-length path)))
(char=? #\/ (string-ref path 0)))]
[path (separate-path-strings
;; If path is "" and the input is an absolute URL
;; with a hostname, then the intended path is "/",
;; but the URL is missing a "/" at the end.
path
#;
(if (and (string=? path "") host) "/" path))]
[query (if query (form-urlencoded->alist query) '())]
[fragment (uri-decode/maybe fragment)])
(when (string? scheme) (string-lowercase! scheme))
(when (string? host) (string-lowercase! host))
(make-url scheme user host port abs? path query fragment)))
(cdr (or (regexp-match url-rx str)
(url-error "Invalid URL string: ~e" str)))))
(define (uri-decode/maybe f) ;; cribbed from 5.2.4 in rfc 3986
;; If #f, and leave unmolested any % that is followed by hex digit ;; the strange cases 2 and 4 implicitly change urls
;; if a % is not followed by a hex digit, replace it with %25 ;; with paths segments "." and ".." at the end
;; in an attempt to be "friendly" ;; into "./" and "../" respectively
(and f (uri-decode (regexp-replace* "%([^0-9a-fA-F])" f "%25\\1")))) (define (remove-dot-segments path)
(let loop ([path path] [result '()])
(cond
[(null? path) (reverse result)]
[(and (eq? (path/param-path (car path)) 'same)
(null? (cdr path)))
(loop (cdr path)
(cons (make-path/param "" '()) result))]
[(eq? (path/param-path (car path)) 'same)
(loop (cdr path)
result)]
[(and (eq? (path/param-path (car path)) 'up)
(null? (cdr path))
(not (null? result)))
(loop (cdr path)
(cons (make-path/param "" '()) (cdr result)))]
[(and (eq? (path/param-path (car path)) 'up)
(not (null? result)))
(loop (cdr path) (cdr result))]
[(and (eq? (path/param-path (car path)) 'up)
(null? result))
;; when we go up too far, just drop the "up"s.
(loop (cdr path) result)]
[else
(loop (cdr path) (cons (car path) result))])))
;; separate-path-strings : string[starting with /] -> (listof path/param) ;; call/input-url : url x (url -> in-port) x (in-port -> T)
(define (separate-path-strings str) ;; [x list (str)] -> T
(let ([strs (regexp-split #rx"/" str)]) (define call/input-url
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs)))) (let ([handle-port
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client))
(lambda () (close-input-port server->client))))])
(case-lambda
[(url getter handler)
(handle-port (getter url) handler)]
[(url getter handler params)
(handle-port (getter url params) handler)])))
(define (separate-params s) ;; purify-port : in-port -> header-string
(let ([lst (map path-segment-decode (regexp-split #rx";" s))]) (define (purify-port port)
(make-path/param (car lst) (cdr lst)))) (let ([m (regexp-match-peek-positions
#rx"^HTTP/.*?((\r\n\r\n)|(\n\n)|(\r\r))" port)])
(if m
(read-string (cdar m) port)
"")))
(define (path-segment-decode p) (define character-set-size 256)
(cond [(string=? p "..") 'up]
[(string=? p ".") 'same]
[else (uri-path-segment-decode p)]))
(define (path-segment-encode p) ;; netscape/string->url : str -> url
(cond [(eq? p 'up) ".."] (define (netscape/string->url string)
[(eq? p 'same) "."] (let ([url (string->url string)])
[(equal? p "..") "%2e%2e"] (if (url-scheme url)
[(equal? p ".") "%2e"] url
[else (uri-path-segment-encode p)])) (if (string=? string "")
(url-error "Can't resolve empty string as URL")
(begin
(set-url-scheme! url
(if (char=? (string-ref string 0) #\/) "file" "http"))
url)))))
(define (combine-path-strings absolute? path/params) ;; string->url : str -> url
(cond [(null? path/params) ""] ;; New implementation, mostly provided by Neil Van Dyke
[else (let ([p (join "/" (map join-params path/params))]) (define url-rx
(if absolute? (string-append "/" p) p))])) (regexp (string-append
"^"
"[ \t\f\r\n]*"
"(?:" ; <A front-opt
"(?:([a-zA-Z]*):)?" ; =1 scheme-colon-opt
"(?:" ; <B slashslash-opt
"//"
"(?:([^:/@;?#]*)@)?" ; =2 user-at-opt
"([^:/@;?#]*)?" ; =3 host-opt
"(?::([0-9]*))?" ; =4 colon-port-opt
")?" ; >B slashslash-opt
")?" ; >A front-opt
"([^?#]*)" ; =5 path
"(?:\\?([^#]*))?" ; =6 question-query-opt
"(?:#(.*))?" ; =7 hash-fragment-opt
"[ \t\f\r\n]*"
"$")))
(define (string->url str)
(apply
(lambda (scheme user host port path query fragment)
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(when (and (equal? "" port) (equal? "file" scheme)
(eq? 'windows url:os-type))
(set! path (string-append host ":" path))
(set! host #f))
(let* ([user (uri-decode/maybe user)]
[port (and port (string->number port))]
[abs? (and (not (= 0 (string-length path)))
(char=? #\/ (string-ref path 0)))]
[path (separate-path-strings
;; If path is "" and the input is an absolute URL
;; with a hostname, then the intended path is "/",
;; but the URL is missing a "/" at the end.
path
#;
(if (and (string=? path "") host) "/" path))]
[query (if query (form-urlencoded->alist query) '())]
[fragment (uri-decode/maybe fragment)])
(when (string? scheme) (string-lowercase! scheme))
(when (string? host) (string-lowercase! host))
(make-url scheme user host port abs? path query fragment)))
(cdr (or (regexp-match url-rx str)
(url-error "Invalid URL string: ~e" str)))))
(define (join-params s) (define (uri-decode/maybe f)
(join ";" (map path-segment-encode ;; If #f, and leave unmolested any % that is followed by hex digit
(cons (path/param-path s) (path/param-param s))))) ;; if a % is not followed by a hex digit, replace it with %25
;; in an attempt to be "friendly"
(and f (uri-decode (regexp-replace* "%([^0-9a-fA-F])" f "%25\\1"))))
(define (join sep strings) ;; separate-path-strings : string[starting with /] -> (listof path/param)
(cond [(null? strings) ""] (define (separate-path-strings str)
[(null? (cdr strings)) (car strings)] (let ([strs (regexp-split #rx"/" str)])
[else (map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
(let loop ([strings (cdr strings)] [r (list (car strings))])
(if (null? strings)
(apply string-append (reverse! r))
(loop (cdr strings) (list* (car strings) sep r))))]))
)) (define (separate-params s)
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
(make-path/param (car lst) (cdr lst))))
(define (path-segment-decode p)
(cond [(string=? p "..") 'up]
[(string=? p ".") 'same]
[else (uri-path-segment-decode p)]))
(define (path-segment-encode p)
(cond [(eq? p 'up) ".."]
[(eq? p 'same) "."]
[(equal? p "..") "%2e%2e"]
[(equal? p ".") "%2e"]
[else (uri-path-segment-encode p)]))
(define (combine-path-strings absolute? path/params)
(cond [(null? path/params) ""]
[else (let ([p (join "/" (map join-params path/params))])
(if absolute? (string-append "/" p) p))]))
(define (join-params s)
(join ";" (map path-segment-encode
(cons (path/param-path s) (path/param-param s)))))
(define (join sep strings)
(cond [(null? strings) ""]
[(null? (cdr strings)) (car strings)]
[else
(let loop ([strings (cdr strings)] [r (list (car strings))])
(if (null? strings)
(apply string-append (reverse! r))
(loop (cdr strings) (list* (car strings) sep r))))]))
))

10
collects/net/url.ss
View File

@ -1,7 +1,7 @@
(module url mzscheme (module url mzscheme
(require (lib "unit.ss") (require (lib "unit.ss")
(lib "contract.ss") (lib "contract.ss")
"url-structs.ss" "url-structs.ss"
"url-sig.ss" "url-sig.ss"
"url-unit.ss" "url-unit.ss"
"tcp-sig.ss" "tcp-sig.ss"
@ -36,10 +36,10 @@
(purify-port (input-port? . -> . string?)) (purify-port (input-port? . -> . string?))
(netscape/string->url (string? . -> . url?)) (netscape/string->url (string? . -> . url?))
(call/input-url (opt->* (url? (call/input-url (opt->* (url?
(opt-> (url?) ((listof string?)) input-port?) (opt-> (url?) ((listof string?)) input-port?)
(input-port? . -> . any)) (input-port? . -> . any))
((listof string?)) ((listof string?))
any)) any))
(combine-url/relative (url? string? . -> . url?)) (combine-url/relative (url? string? . -> . url?))
(url-exception? (any/c . -> . boolean?)) (url-exception? (any/c . -> . boolean?))
(current-proxy-servers (current-proxy-servers