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

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

@ -3,7 +3,7 @@
(struct cgi-error ()) (struct cgi-error ())
(struct incomplete-%-suffix (chars)) (struct incomplete-%-suffix (chars))
(struct invalid-%-suffix (char)) (struct invalid-%-suffix (char))
;; -- cgi methods -- ;; -- cgi methods --
get-bindings get-bindings
get-bindings/post get-bindings/post
@ -15,9 +15,8 @@
extract-bindings extract-bindings
extract-binding/single extract-binding/single
get-cgi-method get-cgi-method
;; -- general HTML utilities -- ;; -- general HTML utilities --
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

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

@ -2,7 +2,7 @@
;;; <cookie-unit.ss> ---- HTTP cookies library ;;; <cookie-unit.ss> ---- HTTP cookies library
;;; Time-stamp: <03/04/25 10:50:05 noel> ;;; Time-stamp: <03/04/25 10:50:05 noel>
;;; ;;;
;;; Copyright (C) 2002 by Francisco Solsona. ;;; Copyright (C) 2002 by Francisco Solsona.
;;; ;;;
;;; This file is part of net. ;;; This file is part of net.
@ -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,29 +253,30 @@
;; 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 "\\\\\"") "\""))
;; string -> rfc2109:value? ;; string -> rfc2109:value?
(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)))
) )

6
collects/net/cookie.ss
View File

@ -1,8 +1,6 @@
(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^)
(define-values/invoke-unit/infer cookie@)) (define-values/invoke-unit/infer 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)

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

16
collects/net/doc.txt
View File

@ -31,7 +31,7 @@ TYPES ----------------------------------------------------------------
_url struct_ _url struct_
(define-struct url (scheme user host port path-absolute? path query fragment)) (define-struct url (scheme user host port path-absolute? path query fragment))
> url-scheme : url -> (union false/c string?) > url-scheme : url -> (union false/c string?)
> url-user : url -> (union false/c string?) > url-user : url -> (union false/c string?)
> url-host : url -> (union false/c string?) > url-host : url -> (union false/c string?)
> url-port : url -> (union false/c number?) > url-port : url -> (union false/c number?)
@ -497,12 +497,12 @@ EXCEPTIONS -----------------------------------------------------------
PROCEDURES ----------------------------------------------------------- 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
@ -2234,7 +2234,7 @@ PROCEDURES -----------------------------------------------------------
The `separator-mode-sym' argument must be either 'amp or 'semi to The `separator-mode-sym' argument must be either 'amp or 'semi to
select the separator. The default is 'semi. select the separator. The default is 'semi.
> (form-urlencoded->alist string [separator-mode-sym]) > (form-urlencoded->alist string [separator-mode-sym])
: String -> alist : String -> alist

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

@ -1,8 +1,7 @@
(module ftp-sig (lib "a-signature.ss") (module ftp-sig (lib "a-signature.ss")
ftp-cd ftp-cd
ftp-establish-connection ftp-establish-connection* ftp-establish-connection ftp-establish-connection*
ftp-close-connection ftp-close-connection
ftp-directory-list ftp-directory-list
ftp-download-file ftp-download-file
ftp-make-file-seconds) ftp-make-file-seconds)

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

@ -1,215 +1,217 @@
(module ftp-unit (lib "a-unit.ss") (module ftp-unit (lib "a-unit.ss")
;; Version 0.2 ;; Version 0.2
;; 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 re:multi-response-start #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 tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(when expected
(unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3)))
(if (bytes? expected)
(list expected)
expected))
(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
;;
;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info.
;;
;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes) (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(cond (define re:response-end #rx#"^[0-9][0-9][0-9] ")
[(equal? #"Jan" month-bytes) 1]
[(equal? #"Feb" month-bytes) 2]
[(equal? #"Mar" month-bytes) 3]
[(equal? #"Apr" month-bytes) 4]
[(equal? #"May" month-bytes) 5]
[(equal? #"Jun" month-bytes) 6]
[(equal? #"Jul" month-bytes) 7]
[(equal? #"Aug" month-bytes) 8]
[(equal? #"Sep" month-bytes) 9]
[(equal? #"Oct" month-bytes) 10]
[(equal? #"Nov" month-bytes) 11]
[(equal? #"Dec" month-bytes) 12]))
(define (bytes->number bytes) (define (check-expected-result line expected)
(string->number (bytes->string/latin-1 bytes))) (when expected
(unless (ormap (lambda (expected)
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") (bytes=? expected (subbytes line 0 3)))
(if (bytes? expected)
(list expected)
expected))
(error 'ftp "exected result code ~a, got ~a" expected line))))
(define (ftp-make-file-seconds ftp-date-str) ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) ;;
(if (not (list-ref date-list 4)) ;; Checks a standard-format response, checking for the given
(find-seconds 0 ;; expected 3-digit result code if expected is not #f.
0 ;;
2 ;; While checking, the function sends reponse lines to
(bytes->number (list-ref date-list 6)) ;; diagnostic-accum. This function -accum functions can return a
(get-month (list-ref date-list 5)) ;; value that accumulates over multiple calls to the function, and
(bytes->number (list-ref date-list 7))) ;; accum-start is used as the initial value. Use `void' and
(+ (find-seconds 0 ;; `(void)' to ignore the response info.
(bytes->number (list-ref date-list 4)) ;;
(bytes->number (list-ref date-list 3)) ;; If an unexpected result is found, an exception is raised, and the
(bytes->number (list-ref date-list 2)) ;; stream is left in an undefined state.
(get-month (list-ref date-list 1)) (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
2002) (flush-output tcpout)
tzoffset)))) (let ([line (read-bytes-line tcpin 'any)])
(cond
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
(define (establish-data-connection tcp-ports) (define (get-month month-bytes)
(fprintf (tcp-connection-out tcp-ports) "PASV~n") (cond [(assoc month-bytes
(let ([response (ftp-check-response (tcp-connection-in tcp-ports) '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(tcp-connection-out tcp-ports) (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
#"227" (#"Nov" 11) (#"Dec" 12)))
(lambda (s ignore) s) ;; should be the only response => cadr]
(void))]) [else (error 'get-month "bad month: ~s" month-bytes)]))
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out) (tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(fprintf (tcp-connection-out tcp-ports) "TYPE I~n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"200" void (void))
(close-output-port tcp-data-out)
tcp-data))))
;; Used where version 0.1a printed responses: (define (bytes->number bytes)
(define (print-msg s ignore) (string->number (bytes->string/latin-1 bytes)))
;; (printf "~a~n" s)
(void))
(define (ftp-establish-connection* in out username password) (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response in out (list #"331" #"230")
(lambda (line 230?)
(or 230? (regexp-match #rx#"^230" line)))
#f)])
(unless no-password?
(display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out)
(ftp-check-response in out #"230" void (void))))
(make-tcp-connection in out))
(define (ftp-establish-connection server-address server-port username password)
(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports) (define (ftp-make-file-seconds ftp-date-str)
(fprintf (tcp-connection-out tcp-ports) "QUIT~n") (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"221" void (void)) (if (not (list-ref date-list 4))
(close-input-port (tcp-connection-in tcp-ports)) (find-seconds 0
(close-output-port (tcp-connection-out tcp-ports))) 0
2
(bytes->number (list-ref date-list 6))
(get-month (list-ref date-list 5))
(bytes->number (list-ref date-list 7)))
(+ (find-seconds 0
(bytes->number (list-ref date-list 4))
(bytes->number (list-ref date-list 3))
(bytes->number (list-ref date-list 2))
(get-month (list-ref date-list 1))
2002)
tzoffset))))
(define (filter-tcp-data tcp-data-port regular-exp) (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(let loop ()
(let ([theline (read-bytes-line tcp-data-port 'any)])
(cond
[(or (eof-object? theline)
(< (bytes-length theline) 3))
null]
[(regexp-match regular-exp theline)
=> (lambda (m)
(cons (cdr m) (loop)))]
[else
;; ignore unrecognized lines?
(loop)]))))
(define (ftp-cd ftp-ports new-dir) (define (establish-data-connection tcp-ports)
(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") (fprintf (tcp-connection-out tcp-ports) "PASV\n")
(tcp-connection-out ftp-ports)) (let ([response (ftp-check-response
(ftp-check-response (tcp-connection-in ftp-ports) (tcp-connection-out ftp-ports) (tcp-connection-in tcp-ports)
#"250" void (void))) (tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ; should be the only response
(void))])
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"200" void (void))
(close-output-port tcp-data-out)
tcp-data))))
(define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") ;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a\n" s)
(void))
(define (ftp-directory-list tcp-ports) (define (ftp-establish-connection* in out username password)
(let ([tcp-data (establish-data-connection tcp-ports)]) (ftp-check-response in out #"220" print-msg (void))
(fprintf (tcp-connection-out tcp-ports) "LIST~n") (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) (let ([no-password? (ftp-check-response
#"150" void (void)) in out (list #"331" #"230")
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) (lambda (line 230?)
(close-input-port tcp-data) (or 230? (regexp-match #rx#"^230" line)))
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #f)])
#"226" print-msg (void)) (unless no-password?
(map (lambda (l) (map bytes->string/locale l)) dir-list)))) (display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
out)
(ftp-check-response in out #"230" void (void))))
(make-tcp-connection in out))
(define (ftp-download-file tcp-ports folder filename) (define (ftp-establish-connection server-address server-port username password)
;; Save the file under the name tmp.file, (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
;; rename it once download is complete (ftp-establish-connection* tcpin tcpout username password)))
;; this assures we don't over write any existing file without having a good file down
(let* ([tmpfile (make-temporary-file (string-append
(regexp-replace #rx"~"
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile 'replace)]
[tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")]
[tcp-data (establish-data-connection tcp-ports)])
(display tcpstring (tcp-connection-out tcp-ports))
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
#"150" print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (printf "FTP Client Installed...~n") (define (ftp-close-connection tcp-ports)
) (fprintf (tcp-connection-out tcp-ports) "QUIT\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"221" void (void))
(close-input-port (tcp-connection-in tcp-ports))
(close-output-port (tcp-connection-out tcp-ports)))
(define (filter-tcp-data tcp-data-port regular-exp)
(let loop ()
(let ([theline (read-bytes-line tcp-data-port 'any)])
(cond [(or (eof-object? theline) (< (bytes-length theline) 3))
null]
[(regexp-match regular-exp theline)
=> (lambda (m) (cons (cdr m) (loop)))]
[else
;; ignore unrecognized lines?
(loop)]))))
(define (ftp-cd ftp-ports new-dir)
(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
(tcp-connection-out ftp-ports))
(ftp-check-response (tcp-connection-in ftp-ports)
(tcp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line
#rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define (ftp-directory-list tcp-ports)
(let ([tcp-data (establish-data-connection tcp-ports)])
(fprintf (tcp-connection-out tcp-ports) "LIST\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" void (void))
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(map (lambda (l) (map bytes->string/locale l)) dir-list))))
(define (ftp-download-file tcp-ports folder filename)
;; Save the file under the name tmp.file, rename it once download is
;; complete this assures we don't over write any existing file without
;; having a good file down
(let* ([tmpfile (make-temporary-file
(string-append
(regexp-replace
#rx"~"
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile 'replace)]
[tcpstring (bytes-append #"RETR "
(string->bytes/locale filename)
#"\n")]
[tcp-data (establish-data-connection tcp-ports)])
(display tcpstring (tcp-connection-out tcp-ports))
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (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)

706
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/bytes CRLF/bytes)
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:")) (define empty-header CRLF)
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:") (define empty-header/bytes CRLF/bytes)
(define re:continue (regexp "^[ \t\v]"))
(define re:continue/bytes #rx#"^[ \t\v]")
(define (validate-header s)
(if (bytes? s)
;; legal char check not needed per rfc 2822, IIUC.
(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) (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)"))) (define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re:continue (regexp "^[ \t\v]"))
(define (extract-field field header) (define re:continue/bytes #rx#"^[ \t\v]")
(if (bytes? header)
(let ([m (regexp-match-positions (define (validate-header s)
(make-field-start-regexp/bytes field) (if (bytes? s)
header)]) ;; legal char check not needed per rfc 2822, IIUC.
(and m (let ([len (bytes-length s)])
(let ([s (subbytes header (let loop ([offset 0])
(cdaddr m) (cond
(bytes-length header))]) [(and (= (+ offset 2) len)
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) (bytes=? CRLF/bytes (subbytes s offset len)))
(if m (void)] ; validated
(subbytes s 0 (caar m)) [(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
;; Rest of header is this field, but strip trailing CRLFCRLF: [(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 (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(if m
(let* ([pre (subbytes header 0 (caaddr m))]
[s (subbytes header (cdaddr m))]
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
(bytes-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(if m
(let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))]
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
(string-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))))
(define (remove-field field header)
(replace-field field #f header))
(define (insert-field field data header)
(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-all-fields header)
(if (bytes? header)
(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 (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$" (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))))))
(define (replace-field field data header) ;; It's slightly less obvious how to generalize the functions that don't
(if (bytes? header) ;; accept a header as input; for lack of an obvious solution (and free time),
(let ([m (regexp-match-positions ;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(make-field-start-regexp/bytes field)
header)]) (define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
(insert-field
"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)
(replace-field field #f header))
(define (insert-field field data header)
(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-all-fields header)
(if (bytes? header)
(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 (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
;; as input; for lack of an obvious solution (and free time), I'm stopping the string->bytes
;; translation here. -- JBC, 2006-07-31
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
(insert-field
"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) (define (select-result form name addr full)
(if (null? l) (case form
"" [(name) name]
(format "~a~a" [(address) addr]
(car l) [(full) full]
(apply [(all) (list name addr full)]))
string-append
(map
(lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas) (define (one-result form s)
(splice datas "\r\n\t")) (select-result form s s s))
;; Extracting Addresses ;; (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 blank "[ \t\n\r\v]") (define (extract-one-name orig form)
(define nonblank "[^ \t\n\r\v]") (let loop ([s orig][form form])
(define re:all-blank (regexp (format "^~a*$" blank))) (cond
(define re:quoted (regexp "\"[^\"]*\"")) ;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
(define re:parened (regexp "[(][^)]*[)]")) [(regexp-match re:parened-name s)
(define re:comma (regexp ",")) => (lambda (m)
(define re:comma-separated (regexp "([^,]*),(.*)")) (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-addresses s form) (define (extract-angle-addr s orig)
(unless (memq form '(name address full all)) (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(raise-type-error 'extract-addresses (error 'extract-address "too many angle brackets: ~a" s)
"form: 'name, 'address, 'full, or 'all" (let ([m (regexp-match re:normal-name s)])
form)) (if m
(if (or (not s) (regexp-match re:all-blank s)) (extract-simple-addr (cadr m) orig)
null (error 'extract-address "cannot parse address: ~a" orig)))))
(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) (define (extract-simple-addr s orig)
(select-result form s s s)) (cond [(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank))) (define (assemble-address-field addresses)
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank))) (if (null? addresses)
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank))) ""
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank))) (let loop ([addresses (cdr addresses)]
(define re:double-less (regexp "<.*<")) [s (car addresses)]
(define re:double-greater (regexp ">.*>")) [len (string-length (car addresses))])
(define re:bad-chars (regexp "[,\"()<>]")) (if (null? addresses)
(define re:tail-blanks (regexp (format "~a+$" blank))) s
(define re:head-blanks (regexp (format "^~a+" blank))) (let* ([addr (car addresses)]
[alen (string-length addr)])
(define (extract-one-name orig form) (if (<= 72 (+ len alen))
(let loop ([s orig][form form]) (loop (cdr addresses)
(cond (format "~a,~a~a~a~a"
;; ?!?!? Where does the "addr (name)" standard come from ?!?!? s #\return #\linefeed
[(regexp-match re:parened-name s) #\tab addr)
=> (lambda (m) alen)
(let ([name (caddr m)] (loop (cdr addresses)
[all (loop (cadr m) 'all)]) (format "~a, ~a" s addr)
(select-result form (+ len alen 2)))))))))
(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@)

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

@ -1,7 +1,7 @@
(module imap-sig (lib "a-signature.ss") (module imap-sig (lib "a-signature.ss")
imap-port-number imap-port-number
imap-connection? imap-connection?
imap-connect imap-connect* imap-connect imap-connect*
imap-disconnect imap-disconnect
imap-force-disconnect imap-force-disconnect
@ -10,7 +10,7 @@
imap-noop imap-noop
imap-status imap-status
imap-poll imap-poll
imap-new? imap-new?
imap-messages imap-messages
imap-recent imap-recent
@ -18,21 +18,20 @@
imap-uidvalidity imap-uidvalidity
imap-unseen imap-unseen
imap-reset-new! imap-reset-new!
imap-get-expunges imap-get-expunges
imap-pending-expunges? imap-pending-expunges?
imap-get-updates imap-get-updates
imap-pending-updates? imap-pending-updates?
imap-get-messages imap-get-messages
imap-copy imap-append imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag imap-store imap-flag->symbol symbol->imap-flag
imap-expunge imap-expunge
imap-mailbox-exists? imap-mailbox-exists?
imap-create-mailbox imap-create-mailbox
imap-list-child-mailboxes imap-list-child-mailboxes
imap-mailbox-flags imap-mailbox-flags
imap-get-hierarchy-delimiter) imap-get-hierarchy-delimiter)

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

File diff suppressed because it is too large Load Diff

23
collects/net/imap.ss
View File

@ -1,11 +1,8 @@
(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@)
(provide/contract (provide/contract
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)] [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
[imap-list-child-mailboxes [imap-list-child-mailboxes
@ -14,7 +11,7 @@
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?) (imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
. -> . . -> .
(listof (list/c (listof symbol?) bytes?))))]) (listof (list/c (listof symbol?) bytes?))))])
(provide (provide
imap-connection? imap-connection?
imap-connect imap-connect* imap-connect imap-connect*
@ -25,7 +22,7 @@
imap-noop imap-noop
imap-poll imap-poll
imap-status imap-status
imap-port-number ; a parameter imap-port-number ; a parameter
imap-new? imap-new?
@ -35,18 +32,18 @@
imap-uidvalidity imap-uidvalidity
imap-unseen imap-unseen
imap-reset-new! imap-reset-new!
imap-get-expunges imap-get-expunges
imap-pending-expunges? imap-pending-expunges?
imap-get-updates imap-get-updates
imap-pending-updates? imap-pending-updates?
imap-get-messages imap-get-messages
imap-copy imap-append imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag imap-store imap-flag->symbol symbol->imap-flag
imap-expunge imap-expunge
imap-mailbox-exists? imap-mailbox-exists?
imap-create-mailbox imap-create-mailbox
imap-mailbox-flags)) imap-mailbox-flags))

4
collects/net/mime-sig.ss
View File

@ -8,7 +8,7 @@
(struct empty-type () -setters -constructor) (struct empty-type () -setters -constructor)
(struct empty-subtype () -setters -constructor) (struct empty-subtype () -setters -constructor)
(struct empty-disposition-type () -setters -constructor) (struct empty-disposition-type () -setters -constructor)
;; -- basic mime structures -- ;; -- basic mime structures --
(struct message (version entity fields)) (struct message (version entity fields))
(struct entity (struct entity
@ -20,7 +20,7 @@
(type filename creation (type filename creation
modification read modification read
size params)) size params))
;; -- mime methods -- ;; -- mime methods --
mime-analyze mime-analyze
) )

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

File diff suppressed because it is too large Load Diff

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

@ -2,7 +2,7 @@
;;; <mime-util.ss> ---- Extra utilities ;;; <mime-util.ss> ---- Extra utilities
;;; Time-stamp: <01/05/07 17:41:12 solsona> ;;; Time-stamp: <01/05/07 17:41:12 solsona>
;;; ;;;
;;; Copyright (C) 2001 by Francisco Solsona. ;;; Copyright (C) 2001 by Francisco Solsona.
;;; ;;;
;;; This file is part of mime-plt. ;;; This file is part of mime-plt.
@ -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

12
collects/net/mime.ss
View File

@ -1,8 +1,8 @@
;;; ;;;
;;; <mime.ss> ---- MIME support ;;; <mime.ss> ---- MIME support
;;; ;;;
;;; Copyright (C) 2002 by PLT. ;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing. ;;; Copyright (C) 2001 by Wish Computing.
;;; ;;;
;;; This file is part of mime ;;; This file is part of mime
@ -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^)
@ -43,9 +43,9 @@
(define-compound-unit/infer mime@2 (import) (export mime^) (define-compound-unit/infer mime@2 (import) (export mime^)
(link base64@ qp@ head@ mime@)) (link base64@ qp@ head@ mime@))
(define-values/invoke-unit/infer mime@2) (define-values/invoke-unit/infer mime@2)
(provide-signature-elements mime^)) (provide-signature-elements mime^))
;;; mime.ss ends here ;;; mime.ss ends here

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

@ -5,7 +5,7 @@
head-of-message body-of-message head-of-message body-of-message
newnews-since generic-message-command newnews-since generic-message-command
make-desired-header extract-desired-headers make-desired-header extract-desired-headers
(struct nntp ()) (struct nntp ())
(struct unexpected-response (code text)) (struct unexpected-response (code text))
(struct bad-status-line (line)) (struct bad-status-line (line))
@ -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 ()))

602
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*
(case-lambda
[(receiver sender) (connect-to-server* receiver sender "unspecified"
"unspecified")]
[(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line)
(let ((communicator (make-communicator sender receiver server-name
port-number)))
(let-values (((code response)
(get-single-line-response communicator)))
(case code
[(201) communicator]
((200)
communicator)
(else
((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)))))]))
;; connect-to-server :
;; string [x number] -> commnicator
(define connect-to-server (define connect-to-server*
(opt-lambda (server-name (port-number default-nntpd-port-number)) (case-lambda
(let-values (((receiver sender) [(receiver sender)
(tcp-connect server-name port-number))) (connect-to-server* receiver sender "unspecified" "unspecified")]
(connect-to-server* receiver sender server-name port-number)))) [(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line)
(let ([communicator (make-communicator sender receiver server-name
port-number)])
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(200 201) communicator]
[else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)])))]))
;; close-communicator : ;; connect-to-server :
;; communicator -> () ;; string [x number] -> commnicator
(define close-communicator (define connect-to-server
(lambda (communicator) (opt-lambda (server-name (port-number default-nntpd-port-number))
(close-input-port (communicator-receiver communicator)) (let-values ([(receiver sender)
(close-output-port (communicator-sender communicator)))) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; disconnect-from-server : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define close-communicator
(lambda (communicator) (lambda (communicator)
(send-to-server communicator "QUIT") (close-input-port (communicator-receiver communicator))
(let-values (((code response) (close-output-port (communicator-sender communicator))))
(get-single-line-response communicator)))
(case code
((205)
(close-communicator communicator))
(else
((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s"
code response)
code response))))))
;; authenticate-user : ;; disconnect-from-server :
;; communicator x user-name x password -> () ;; communicator -> ()
;; the password is not used if the server does not ask for it.
(define authenticate-user (define disconnect-from-server
(lambda (communicator user password) (lambda (communicator)
(define (reject code response) (send-to-server communicator "QUIT")
((signal-error make-authentication-rejected (let-values ([(code response)
"authentication rejected (~s ~s)" (get-single-line-response communicator)])
code response))) (case code
(define (unexpected code response) [(205)
((signal-error make-unexpected-response (close-communicator communicator)]
"unexpected response for authentication: ~s ~s" [else
code response) ((signal-error make-unexpected-response
code response)) "unexpected dis-connect response: ~s ~s"
(send-to-server communicator "AUTHINFO USER ~a" user) code response)
(let-values (((code response) code response)]))))
(get-single-line-response communicator)))
;; authenticate-user :
;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it.
(define authenticate-user
(lambda (communicator user password)
(define (reject code response)
((signal-error make-authentication-rejected
"authentication rejected (~s ~s)"
code response)))
(define (unexpected code response)
((signal-error make-unexpected-response
"unexpected response for authentication: ~s ~s"
code response)
code response))
(send-to-server communicator "AUTHINFO USER ~a" user)
(let-values ([(code response) (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
(generic-message-command "NEWNEWS" 230))
;; make-desired-header : (define make-desired-header
;; string -> desired (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))))
":"))))
(define make-desired-header ;; extract-desired-headers :
(lambda (raw-header) ;; list (string) x list (desired) -> list (string)
(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@)

4
collects/net/pop3-sig.ss
View File

@ -6,9 +6,9 @@
get-message/complete get-message/headers get-message/body get-message/complete get-message/headers get-message/body
delete-message delete-message
get-unique-id/single get-unique-id/all get-unique-id/single get-unique-id/all
make-desired-header extract-desired-headers make-desired-header extract-desired-headers
(struct pop3 ()) (struct pop3 ())
(struct cannot-connect ()) (struct cannot-connect ())
(struct username-rejected ()) (struct username-rejected ())

677
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 :
;; string [x number] -> communicator
(define connect-to-server ;; connect-to-server :
(opt-lambda (server-name (port-number default-pop-port-number)) ;; string [x number] -> communicator
(let-values (((receiver sender) (tcp-connect server-name port-number)))
(connect-to-server* receiver sender server-name port-number))))
;; authenticate/plain-text : (define connect-to-server
;; string x string x communicator -> () (opt-lambda (server-name (port-number default-pop-port-number))
(let-values ([(receiver sender) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; -- if authentication succeeds, sets the communicator's state to ;; authenticate/plain-text :
;; transaction. ;; string x string x communicator -> ()
(define authenticate/plain-text ;; -- if authentication succeeds, sets the communicator's state to
(lambda (username password communicator) ;; transaction.
(let ((sender (communicator-sender communicator)))
(send-to-server communicator "USER ~a" username)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(send-to-server communicator "PASS ~a" password)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(set-communicator-state! communicator 'transaction))
((-err? status)
((signal-error make-password-rejected
"password was rejected"))))))
((-err? status)
((signal-error make-username-rejected
"username was rejected"))))))))
;; get-mailbox-status : (define authenticate/plain-text
;; communicator -> number x number (lambda (username password communicator)
(let ([sender (communicator-sender communicator)])
(send-to-server communicator "USER ~a" username)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(send-to-server communicator "PASS ~a" password)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(set-communicator-state! communicator 'transaction)]
[(-err? status)
((signal-error make-password-rejected
"password was rejected"))]))]
[(-err? status)
((signal-error make-username-rejected
"username was rejected"))])))))
;; -- returns number of messages and number of octets. ;; get-mailbox-status :
;; communicator -> number x number
(define get-mailbox-status ;; -- returns number of messages and number of octets.
(lambda (communicator)
(confirm-transaction-mode
communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values (((status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)))
result)))))
;; get-message/complete : (define get-mailbox-status
;; communicator x number -> list (string) x list (string) (lambda (communicator)
(confirm-transaction-mode
communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values ([(status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)])
result)))))
(define get-message/complete ;; get-message/complete :
(lambda (communicator message) ;; communicator x number -> list (string) x list (string)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(split-header/body (get-multi-line-response communicator)))
((-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message))))))
;; get-message/headers : (define get-message/complete
;; communicator x number -> list (string) (lambda (communicator message)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(split-header/body (get-multi-line-response communicator))]
[(-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message)]))))
(define get-message/headers ;; get-message/headers :
(lambda (communicator message) ;; communicator x number -> list (string)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(let-values (((headers body)
(split-header/body
(get-multi-line-response communicator))))
headers))
((-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message))))))
;; get-message/body : (define get-message/headers
;; communicator x number -> list (string) (lambda (communicator message)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(let-values ([(headers body)
(split-header/body
(get-multi-line-response communicator))])
headers)]
[(-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message)]))))
(define get-message/body ;; get-message/body :
(lambda (communicator message) ;; communicator x number -> list (string)
(let-values (((headers body)
(get-message/complete communicator message)))
body)))
;; split-header/body : (define get-message/body
;; list (string) -> list (string) x list (string) (lambda (communicator message)
(let-values ([(headers body) (get-message/complete communicator message)])
body)))
;; -- returns list of headers and list of body lines. ;; split-header/body :
;; list (string) -> list (string) x list (string)
(define split-header/body ;; -- returns list of headers and list of body lines.
(lambda (lines)
(let loop ((lines lines) (header null))
(if (null? lines)
(values (reverse header) null)
(let ((first (car lines))
(rest (cdr lines)))
(if (string=? first "")
(values (reverse header) rest)
(loop rest (cons first header))))))))
;; delete-message : (define split-header/body
;; communicator x number -> () (lambda (lines)
(let loop ([lines lines] [header null])
(if (null? lines)
(values (reverse header) null)
(let ([first (car lines)]
[rest (cdr lines)])
(if (string=? first "")
(values (reverse header) rest)
(loop rest (cons first header))))))))
(define delete-message ;; delete-message :
(lambda (communicator message) ;; communicator x number -> ()
(confirm-transaction-mode communicator
"cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message)
(let ((status (get-status-response/basic communicator)))
(cond
((-err? status)
((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message)
communicator message))
((+ok? status)
'deleted)))))
;; regexp for UIDL responses (define delete-message
(lambda (communicator message)
(confirm-transaction-mode communicator
"cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(-err? status)
((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message)
communicator message)]
[(+ok? status)
'deleted]))))
(define uidl-regexp #rx"([0-9]+) (.*)") ;; regexp for UIDL responses
;; get-unique-id/single : (define uidl-regexp #rx"([0-9]+) (.*)")
;; communicator x number -> string
(define (get-unique-id/single communicator message) ;; get-unique-id/single :
(confirm-transaction-mode communicator ;; communicator x number -> string
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message)
(let-values (((status result)
(get-status-response/match communicator
uidl-regexp
".*")))
;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond
((-err? status)
((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message)
communicator message))
((+ok? status)
(cadr result)))))
;; get-unique-id/all : (define (get-unique-id/single communicator message)
;; communicator -> list(number x string) (confirm-transaction-mode communicator
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message)
(let-values ([(status result)
(get-status-response/match communicator uidl-regexp ".*")])
;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond
[(-err? status)
((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message)
communicator message)]
[(+ok? status)
(cadr result)])))
(define (get-unique-id/all communicator) ;; get-unique-id/all :
(confirm-transaction-mode communicator ;; communicator -> list(number x string)
"cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL")
(let ((status (get-status-response/basic communicator)))
;; The server response is of the form
;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7
;; .
(map (lambda (l)
(let ((m (regexp-match uidl-regexp l)))
(cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator))))
;; close-communicator : (define (get-unique-id/all communicator)
;; communicator -> () (confirm-transaction-mode communicator
"cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL")
(let ([status (get-status-response/basic communicator)])
;; The server response is of the form
;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7
;; .
(map (lambda (l)
(let ([m (regexp-match uidl-regexp l)])
(cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator))))
(define close-communicator ;; close-communicator :
(lambda (communicator) ;; communicator -> ()
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server : (define close-communicator
;; communicator -> () (lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
(define disconnect-from-server ;; disconnect-from-server :
(lambda (communicator) ;; communicator -> ()
(send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected)
(let ((response (get-status-response/basic communicator)))
(close-communicator communicator)
(cond
((+ok? response) (void))
((-err? response)
((signal-error make-disconnect-not-quiet
"got error status upon disconnect")
communicator))))))
;; send-to-server : (define disconnect-from-server
;; communicator x format-string x list (values) -> () (lambda (communicator)
(send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected)
(let ([response (get-status-response/basic communicator)])
(close-communicator communicator)
(cond
[(+ok? response) (void)]
[(-err? response)
((signal-error make-disconnect-not-quiet
"got error status upon disconnect")
communicator)]))))
(define send-to-server ;; send-to-server :
(lambda (communicator message-template . rest) ;; communicator x format-string x list (values) -> ()
(apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n")
rest)
(flush-output (communicator-sender communicator))))
;; get-one-line-from-server : (define send-to-server
;; iport -> string (lambda (communicator message-template . rest)
(apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n")
rest)
(flush-output (communicator-sender communicator))))
(define get-one-line-from-server ;; get-one-line-from-server :
(lambda (server->client-port) ;; iport -> string
(read-line server->client-port 'return-linefeed)))
;; get-server-status-response : (define get-one-line-from-server
;; communicator -> server-responses x string (lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
;; -- provides the low-level functionality of checking for +OK ;; get-server-status-response :
;; and -ERR, returning an appropriate structure, and returning the ;; communicator -> server-responses x string
;; rest of the status response as a string to be used for further
;; parsing, if necessary.
(define get-server-status-response ;; -- provides the low-level functionality of checking for +OK
(lambda (communicator) ;; and -ERR, returning an appropriate structure, and returning the
(let* ((receiver (communicator-receiver communicator)) ;; rest of the status response as a string to be used for further
(status-line (get-one-line-from-server receiver)) ;; parsing, if necessary.
(r (regexp-match #rx"^\\+OK(.*)" status-line)))
(define get-server-status-response
(lambda (communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]
[r (regexp-match #rx"^\\+OK(.*)" status-line)])
(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)
|# |#

382
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,167 +33,167 @@
(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
;; sort-to-left? ;; sort-to-left?
(lambda (n t) (lambda (n t)
((+ n (tree-left-count t)) . < . (tree-v t))) ((+ n (tree-left-count t)) . < . (tree-v t)))
@ -207,14 +207,14 @@
(set-tree-left-count! t (add1 (tree-left-count t)))) (set-tree-left-count! t (add1 (tree-left-count t))))
;; 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)
|# |#

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

@ -3,7 +3,7 @@
(struct qp-error () -setters -constructor) (struct qp-error () -setters -constructor)
(struct qp-wrong-input () -setters -constructor) (struct qp-wrong-input () -setters -constructor)
(struct qp-wrong-line-size (size) -setters -constructor) (struct qp-wrong-line-size (size) -setters -constructor)
;; -- qp methods -- ;; -- qp methods --
qp-encode qp-encode
qp-decode qp-decode

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

@ -1,8 +1,8 @@
;;; ;;;
;;; <qp-unit.ss> ---- Quoted Printable Implementation ;;; <qp-unit.ss> ---- Quoted Printable Implementation
;;; ;;;
;;; Copyright (C) 2002 by PLT. ;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona. ;;; Copyright (C) 2001 by Francisco Solsona.
;;; ;;;
;;; This file was part of mime-plt. ;;; This file was part of mime-plt.
@ -31,143 +31,143 @@
(import) (import)
(export qp^) (export qp^)
;; Exceptions:
;; String or input-port expected:
(define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size))
;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of STR.
(define qp-encode
(lambda (str)
(let ((out (open-output-bytes)))
(qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out))))
;; qp-decode : string -> string
;; returns STR unqp.
(define qp-decode
(lambda (str)
(let ((out (open-output-bytes)))
(qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out))))
(define qp-decode-stream
(lambda (in out)
(let loop ((ch (read-byte in)))
(unless (eof-object? ch)
(case ch
((61) ;; A "=", which is quoted-printable stuff
(let ((next (read-byte in)))
(cond
((eq? next 10)
;; Soft-newline -- drop it
(void))
((eq? next 13)
;; Expect a newline for a soft CRLF...
(let ((next-next (read-byte in)))
(if (eq? next-next 10)
;; Good.
(loop (read-byte in))
;; Not a LF? Well, ok.
(loop next-next))))
((hex-digit? next)
(let ((next-next (read-byte in)))
(cond ((eof-object? next-next)
(warning "Illegal qp sequence: `=~a'" next)
(display "=" out)
(display next out))
((hex-digit? next-next)
;; qp-encoded
(write-byte (hex-bytes->byte next next-next)
out))
(else
(warning "Illegal qp sequence: `=~a~a'" next next-next)
(write-byte 61 out)
(write-byte next out)
(write-byte next-next out)))))
(else
;; Warning: invalid
(warning "Illegal qp sequence: `=~a'" next)
(write-byte 61 out)
(write-byte next out)))
(loop (read-byte in))))
(else
(write-byte ch out)
(loop (read-byte in))))))))
(define warning
(lambda (msg . args)
(when #f
(fprintf (current-error-port)
(apply format msg args))
(newline (current-error-port)))))
(define (hex-digit? i) ;; Exceptions:
(vector-ref hex-values i)) ;; String or input-port expected:
(define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size))
(define hex-bytes->byte ;; qp-encode : bytes -> bytes
(lambda (b1 b2) ;; returns the quoted printable representation of STR.
(+ (* 16 (vector-ref hex-values b1)) (define qp-encode
(vector-ref hex-values b2)))) (lambda (str)
(let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out))))
(define write-hex-bytes ;; qp-decode : string -> string
(lambda (byte p) ;; returns STR unqp.
(write-byte 61 p) (define qp-decode
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p) (lambda (str)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))) (let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out)
(define re:blanks #rx#"[ \t]+$") (get-output-bytes out))))
(define qp-encode-stream
(opt-lambda (in out [newline-string #"\n"])
(let loop ([col 0])
(if (= col 75)
(begin
;; Soft newline:
(write-byte 61 out)
(display newline-string out)
(loop 0))
(let ([i (read-byte in)])
(cond
[(eof-object? i) (void)]
[(or (= i 10) (= i 13))
(write-byte i out)
(loop 0)]
[(or (<= 33 i 60) (<= 62 i 126)
(and (or (= i 32) (= i 9))
(not (let ([next (peek-byte in)])
(or (eof-object? next) (= next 10) (= next 13))))))
;; single-byte mode:
(write-byte i out)
(loop (add1 col))]
[(>= col 73)
;; need a soft newline first
(write-byte 61 out)
(display newline-string out)
;; now the octect
(write-hex-bytes i out)
(loop 3)]
[else
;; an octect
(write-hex-bytes i out)
(loop (+ col 3))]))))))
;; Tables (define qp-decode-stream
(define hex-values (make-vector 256 #f)) (lambda (in out)
(define hex-bytes (make-vector 16)) (let loop ([ch (read-byte in)])
(let loop ([i 0]) (unless (eof-object? ch)
(unless (= i 10) (case ch
(vector-set! hex-values (+ i 48) i) [(61) ;; A "=", which is quoted-printable stuff
(vector-set! hex-bytes i (+ i 48)) (let ([next (read-byte in)])
(loop (add1 i)))) (cond
(let loop ([i 0]) [(eq? next 10)
(unless (= i 6) ;; Soft-newline -- drop it
(vector-set! hex-values (+ i 65) (+ 10 i)) (void)]
(vector-set! hex-values (+ i 97) (+ 10 i)) [(eq? next 13)
(vector-set! hex-bytes (+ 10 i) (+ i 65)) ;; Expect a newline for a soft CRLF...
(loop (add1 i))))) (let ([next-next (read-byte in)])
(if (eq? next-next 10)
;; Good.
(loop (read-byte in))
;; Not a LF? Well, ok.
(loop next-next)))]
[(hex-digit? next)
(let ([next-next (read-byte in)])
(cond [(eof-object? next-next)
(warning "Illegal qp sequence: `=~a'" next)
(display "=" out)
(display next out)]
[(hex-digit? next-next)
;; qp-encoded
(write-byte (hex-bytes->byte next next-next)
out)]
[else
(warning "Illegal qp sequence: `=~a~a'" next next-next)
(write-byte 61 out)
(write-byte next out)
(write-byte next-next out)]))]
[else
;; Warning: invalid
(warning "Illegal qp sequence: `=~a'" next)
(write-byte 61 out)
(write-byte next out)])
(loop (read-byte in)))]
[else
(write-byte ch out)
(loop (read-byte in))])))))
(define warning
(lambda (msg . args)
(when #f
(fprintf (current-error-port)
(apply format msg args))
(newline (current-error-port)))))
(define (hex-digit? i)
(vector-ref hex-values i))
(define hex-bytes->byte
(lambda (b1 b2)
(+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2))))
(define write-hex-bytes
(lambda (byte p)
(write-byte 61 p)
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
(define re:blanks #rx#"[ \t]+$")
(define qp-encode-stream
(opt-lambda (in out [newline-string #"\n"])
(let loop ([col 0])
(if (= col 75)
(begin
;; Soft newline:
(write-byte 61 out)
(display newline-string out)
(loop 0))
(let ([i (read-byte in)])
(cond
[(eof-object? i) (void)]
[(or (= i 10) (= i 13))
(write-byte i out)
(loop 0)]
[(or (<= 33 i 60) (<= 62 i 126)
(and (or (= i 32) (= i 9))
(not (let ([next (peek-byte in)])
(or (eof-object? next) (= next 10) (= next 13))))))
;; single-byte mode:
(write-byte i out)
(loop (add1 col))]
[(>= col 73)
;; need a soft newline first
(write-byte 61 out)
(display newline-string out)
;; now the octect
(write-hex-bytes i out)
(loop 3)]
[else
;; an octect
(write-hex-bytes i out)
(loop (+ col 3))]))))))
;; Tables
(define hex-values (make-vector 256 #f))
(define hex-bytes (make-vector 16))
(let loop ([i 0])
(unless (= i 10)
(vector-set! hex-values (+ i 48) i)
(vector-set! hex-bytes i (+ i 48))
(loop (add1 i))))
(let loop ([i 0])
(unless (= i 6)
(vector-set! hex-values (+ i 65) (+ 10 i))
(vector-set! hex-values (+ i 97) (+ 10 i))
(vector-set! hex-bytes (+ 10 i) (+ i 65))
(loop (add1 i)))))
;;; qp-unit.ss ends here ;;; qp-unit.ss ends here

10
collects/net/qp.ss
View File

@ -1,8 +1,8 @@
;;; ;;;
;;; <qp.ss> ---- Quoted Printable Encoding/Decoding ;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
;;; ;;;
;;; Copyright (C) 2002 by PLT. ;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona. ;;; Copyright (C) 2001 by Francisco Solsona.
;;; ;;;
;;; This file is part of mime-plt. ;;; This file is part of mime-plt.
@ -26,12 +26,10 @@
;; 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@)
(provide-signature-elements qp^)) (provide-signature-elements qp^))
;;; qp.ss ends here ;;; qp.ss ends here

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

172
collects/net/sendurl.ss
View File

@ -4,9 +4,9 @@
(lib "etc.ss") (lib "etc.ss")
(lib "port.ss") (lib "port.ss")
(lib "sendevent.ss")) (lib "sendevent.ss"))
(provide send-url unix-browser-list browser-preference? external-browser) (provide send-url unix-browser-list browser-preference? external-browser)
(define separate-by-default? (define separate-by-default?
(get-preference 'new-browser-for-urls (lambda () #t))) (get-preference 'new-browser-for-urls (lambda () #t)))
@ -22,122 +22,122 @@
(if (browser-preference? x) (if (browser-preference? x)
x x
(error 'external-browser "~a is not a valid browser preference" x))))) (error 'external-browser "~a is not a valid browser preference" x)))))
; send-url : str [bool] -> void ; send-url : str [bool] -> void
(define send-url (define send-url
(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
(define (custom-browser? x) (define (custom-browser? x)
(and (pair? x) (string? (car x)) (string? (cdr x)))) (and (pair? x) (string? (car x)) (string? (cdr x))))
(define unix-browser-list '(opera galeon netscape mozilla dillo)) (define unix-browser-list '(opera galeon netscape mozilla dillo))
; : (cons tst (listof tst)) -> str ; : (cons tst (listof tst)) -> str
(define (orify l) (define (orify l)
(cond (cond
[(null? (cdr l)) (format "~a" (car l))] [(null? (cdr l)) (format "~a" (car l))]
[(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))] [(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))]
[else [else
(let loop ([l l]) (let loop ([l l])
(cond (cond
[(null? (cdr l)) (format "or ~a" (car l))] [(null? (cdr l)) (format "or ~a" (car l))]
[else (string-append (format "~a, " (car l)) (loop (cdr l)))]))])) [else (string-append (format "~a, " (car l)) (loop (cdr l)))]))]))
; : sym sym -> (U #f str) ; : sym sym -> (U #f str)
; 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)

228
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
auth-user auth-passwd)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(check-reply r 220 w)
(log "hello~n")
(fprintf w "EHLO ~a~a" (smtp-sending-server) crlf)
(check-reply r 250 w)
(when auth-user
(log "auth~n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from~n") (define (smtp-send-message* r w sender recipients header message-lines
(fprintf w "MAIL FROM:<~a>~a" sender crlf) auth-user auth-passwd)
(check-reply r 250 w) (with-handlers ([void (lambda (x)
(close-input-port r)
(log "to~n") (close-output-port w)
(for-each (raise x))])
(lambda (dest) (check-reply r 220 w)
(fprintf w "RCPT TO:<~a>~a" dest crlf) (log "hello\n")
(check-reply r 250 w)) (fprintf w "EHLO ~a~a" (smtp-sending-server) crlf)
recipients) (check-reply r 250 w)
(log "header~n")
(fprintf w "DATA~a" crlf)
(check-reply r 354 w)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a~n" l)
(fprintf w "~a~a" (protect-line l) crlf))
message-lines)
;; After we send the ".", then only break in an emergency (when auth-user
((smtp-sending-end-of-message)) (log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "dot~n") (log "from\n")
(fprintf w ".~a" crlf) (fprintf w "MAIL FROM:<~a>~a" sender crlf)
(flush-output w) (check-reply r 250 w)
(check-reply r 250 w)
(log "to\n")
(log "quit~n") (for-each
(fprintf w "QUIT~a" crlf) (lambda (dest)
(check-reply r 221 w) (fprintf w "RCPT TO:<~a>~a" dest crlf)
(check-reply r 250 w))
(close-output-port w) recipients)
(close-input-port r)))
(log "header\n")
(define smtp-send-message (fprintf w "DATA~a" crlf)
(lambda/kw (server sender recipients header message-lines (check-reply r 354 w)
#:key (fprintf w "~a" header)
[port-no 25] (for-each
[auth-user #f] (lambda (l)
[auth-passwd #f] (log "body: ~a\n" l)
[tcp-connect tcp-connect] (fprintf w "~a~a" (protect-line l) crlf))
#:body message-lines)
(#:optional [opt-port-no port-no]))
(when (null? recipients) ;; After we send the ".", then only break in an emergency
(error 'send-smtp-message "no receivers")) ((smtp-sending-end-of-message))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port)) (log "dot\n")
(tcp-connect server opt-port-no))]) (fprintf w ".~a" crlf)
(smtp-send-message* r w sender recipients header message-lines (flush-output w)
auth-user auth-passwd))))) (check-reply r 250 w)
(log "quit\n")
(fprintf w "QUIT~a" crlf)
(check-reply r 221 w)
(close-output-port w)
(close-input-port r)))
(define smtp-send-message
(lambda/kw (server sender recipients header message-lines
#:key
[port-no 25]
[auth-user #f]
[auth-passwd #f]
[tcp-connect tcp-connect]
#:body
(#:optional [opt-port-no port-no]))
(when (null? recipients)
(error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines
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@)

106
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@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
client-cert-file client-key-file client-root-cert-files)
(unit
(import)
(export tcp^)
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
(define (tcp-abandon-port p) (define (make-ssl-tcp@
(if (input-port? p) server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
(close-input-port p) client-cert-file client-key-file client-root-cert-files)
(close-output-port p))) (unit
(import)
(export tcp^)
(define tcp-accept ssl-accept) (define ctx (ssl-make-client-context))
(define tcp-accept/enable-break ssl-accept/enable-break) (when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
;; accept-ready? doesn't really work for SSL: (define (tcp-abandon-port p)
(define (tcp-accept-ready? p) (if (input-port? p)
#f) (close-input-port p)
(close-output-port p)))
(define tcp-addresses ssl-addresses) (define tcp-accept ssl-accept)
(define tcp-close ssl-close) (define tcp-accept/enable-break ssl-accept/enable-break)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define tcp-listen ;; accept-ready? doesn't really work for SSL:
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f]) (define (tcp-accept-ready? p)
(let ([l (ssl-listen port allow-k reuse? hostname)]) #f)
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
(define tcp-listener? ssl-listener?)))) (define tcp-addresses ssl-addresses)
(define tcp-close ssl-close)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
(define tcp-listener? ssl-listener?))))

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

@ -1,14 +1,14 @@
(module tcp-redirect mzscheme (module tcp-redirect mzscheme
(provide tcp-redirect) (provide tcp-redirect)
(require (lib "unit.ss") (require (lib "unit.ss")
(lib "async-channel.ss") (lib "async-channel.ss")
(lib "etc.ss") (lib "etc.ss")
"tcp-sig.ss") "tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept) (define raw:tcp-accept tcp-accept)
(define raw:tcp-accept/enable-break tcp-accept/enable-break) (define raw:tcp-accept/enable-break tcp-accept/enable-break)
(define raw:tcp-accept-ready? tcp-accept-ready?) (define raw:tcp-accept-ready? tcp-accept-ready?)
(define raw:tcp-addresses tcp-addresses) (define raw:tcp-addresses tcp-addresses)
(define raw:tcp-close tcp-close) (define raw:tcp-close tcp-close)
@ -16,11 +16,11 @@
(define raw:tcp-connect/enable-break tcp-connect/enable-break) (define raw:tcp-connect/enable-break tcp-connect/enable-break)
(define raw:tcp-listen tcp-listen) (define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?) (define raw:tcp-listener? tcp-listener?)
; For tcp-listeners, we use an else branch in the conds since ; For tcp-listeners, we use an else branch in the conds since
; (instead of a contract) I want the same error message as the raw ; (instead of a contract) I want the same error message as the raw
; primitive for bad inputs. ; primitive for bad inputs.
; : (listof nat) -> (unit/sig () -> net:tcp^) ; : (listof nat) -> (unit/sig () -> net:tcp^)
(define tcp-redirect (define tcp-redirect
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"]) (opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
@ -29,12 +29,12 @@
(export tcp^) (export tcp^)
; : (make-pipe-listener nat (channel (cons iport oport))) ; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel)) (define-struct pipe-listener (port channel))
; : port -> void ; : port -> void
(define (tcp-abandon-port tcp-port) (define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port) (when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port))) (raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport ; : listener -> iport oport
(define (tcp-accept tcp-listener) (define (tcp-accept tcp-listener)
(cond (cond
@ -42,7 +42,7 @@
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))]) (let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out)))] (values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)])) [else (raw:tcp-accept tcp-listener)]))
; : listener -> iport oport ; : listener -> iport oport
(define (tcp-accept/enable-break tcp-listener) (define (tcp-accept/enable-break tcp-listener)
(cond (cond
@ -56,20 +56,20 @@
#;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))]) #;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out))) (values (car in-out) (cdr in-out)))
[else (raw:tcp-accept/enable-break tcp-listener)])) [else (raw:tcp-accept/enable-break tcp-listener)]))
; : tcp-listener -> iport oport ; : tcp-listener -> iport oport
; FIX - check channel queue size ; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener) (define (tcp-accept-ready? tcp-listener)
(cond (cond
[(pipe-listener? tcp-listener) #t] [(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)])) [else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-port -> str str ; : tcp-port -> str str
(define (tcp-addresses tcp-port) (define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port) (if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port) (raw:tcp-addresses tcp-port)
(values redirected-address redirected-address))) (values redirected-address redirected-address)))
; : port -> void ; : port -> void
(define (tcp-close tcp-listener) (define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener) (if (tcp-listener? tcp-listener)
@ -77,7 +77,7 @@
(hash-table-remove! (hash-table-remove!
port-table port-table
(pipe-listener-port tcp-listener)))) (pipe-listener-port tcp-listener))))
; : (str nat -> iport oport) -> str nat -> iport oport ; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw) (define (gen-tcp-connect raw)
(lambda (hostname-string port) (lambda (hostname-string port)
@ -99,13 +99,13 @@
(cons to-in to-out)) (cons to-in to-out))
(values from-in from-out)) (values from-in from-out))
(raw hostname-string port)))) (raw hostname-string port))))
; : str nat -> iport oport ; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect)) (define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport ; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break)) (define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag. ; FIX - support the reuse? flag.
(define tcp-listen (define tcp-listen
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f]) (opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
@ -118,22 +118,22 @@
(hash-table-put! port-table port listener) (hash-table-put! port-table port listener)
listener) listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string)))))) (raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
; : tst -> bool ; : tst -> bool
(define (tcp-listener? x) (define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x))) (or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ---------- ; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener) ; : (hash-table nat[port] -> tcp-listener)
(define port-table (make-hash-table)) (define port-table (make-hash-table))
(define redirect-table (define redirect-table
(let ([table (make-hash-table)]) (let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t)) (for-each (lambda (x) (hash-table-put! table x #t))
redirected-ports) redirected-ports)
table)) table))
; : nat -> bool ; : nat -> bool
(define (redirect? port) (define (redirect? port)
(hash-table-get redirect-table port (lambda () #f))))))) (hash-table-get redirect-table port (lambda () #f)))))))

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

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

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

2
collects/net/uri-codec-sig.ss
View File

@ -7,4 +7,4 @@
form-urlencoded-decode form-urlencoded-decode
alist->form-urlencoded alist->form-urlencoded
form-urlencoded->alist form-urlencoded->alist
current-alist-separator-mode) current-alist-separator-mode)

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

@ -1,11 +1,11 @@
;; 1/2/2006: Added a mapping for uri path segments ;; 1/2/2006: Added a mapping for uri path segments
;; that allows more characters to remain decoded ;; that allows more characters to remain decoded
;; -robby ;; -robby
#| #|
People often seem to wonder why semicolons are the default in this code, People often seem to wonder why semicolons are the default in this code,
and not ampersands. Here's are the best answers we have: and not ampersands. Here's are the best answers we have:
From: Doug Orleans <dougorleans@gmail.com> From: Doug Orleans <dougorleans@gmail.com>
@ -50,9 +50,9 @@ Hash: SHA1
Danny Yoo: Danny Yoo:
> > Just out of curiosity, why is current-alist-separator-mode using > > Just out of curiosity, why is current-alist-separator-mode using
> > semicolons by default rather than ampersands? I understand that > > semicolons by default rather than ampersands? I understand that
> > flexibility is nice, but this is the fifth time I've seen people hit this > > flexibility is nice, but this is the fifth time I've seen people hit this
> > as a roadblock; shouldn't the default be what's most commonly used? > > as a roadblock; shouldn't the default be what's most commonly used?
Robby Findler: Robby Findler:
@ -177,200 +177,200 @@ JALQefhDMCATcl2/bZL0bw==
(import) (import)
(export uri-codec^) (export uri-codec^)
(define (self-map-char ch) (cons ch ch))
(define (self-map-chars str) (map self-map-char (string->list str)))
;; The characters that always map to themselves (define (self-map-char ch) (cons ch ch))
(define alphanumeric-mapping (define (self-map-chars str) (map self-map-char (string->list str)))
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; Characters that sometimes map to themselves ;; The characters that always map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()")) (define alphanumeric-mapping
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; The strict URI mapping ;; Characters that sometimes map to themselves
(define uri-mapping (append alphanumeric-mapping safe-mapping)) (define safe-mapping (self-map-chars "-_.!~*'()"))
;; The uri path segment mapping from RFC 3986 ;; The strict URI mapping
(define uri-path-segment-mapping (define uri-mapping (append alphanumeric-mapping safe-mapping))
(append alphanumeric-mapping
safe-mapping
(map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
;; The form-urlencoded mapping ;; The uri path segment mapping from RFC 3986
(define form-urlencoded-mapping (define uri-path-segment-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping)) (append alphanumeric-mapping
safe-mapping
(map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
(define (number->hex-string number) ;; The form-urlencoded mapping
(define (hex n) (string-ref "0123456789ABCDEF" n)) (define form-urlencoded-mapping
(string #\% (hex (quotient number 16)) (hex (modulo number 16)))) `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
(define (hex-string->number hex-string) (define (number->hex-string number)
(string->number (substring hex-string 1 3) 16)) (define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16))))
(define ascii-size 128) (define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string)) (define ascii-size 128)
(define (make-codec-tables alist)
(let ([encoding-table (build-vector ascii-size number->hex-string)]
[decoding-table (build-vector ascii-size values)])
(for-each (match-lambda
[(orig . enc)
(vector-set! encoding-table
(char->integer orig)
(string enc))
(vector-set! decoding-table
(char->integer enc)
(char->integer orig))])
alist)
(values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector) ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(make-codec-tables uri-mapping)) (define (make-codec-tables alist)
(let ([encoding-table (build-vector ascii-size number->hex-string)]
[decoding-table (build-vector ascii-size values)])
(for-each (match-lambda
[(orig . enc)
(vector-set! encoding-table
(char->integer orig)
(string enc))
(vector-set! decoding-table
(char->integer enc)
(char->integer orig))])
alist)
(values encoding-table decoding-table)))
(define-values (uri-path-segment-encoding-vector (define-values (uri-encoding-vector uri-decoding-vector)
uri-path-segment-decoding-vector) (make-codec-tables uri-mapping))
(make-codec-tables uri-path-segment-mapping))
(define-values (form-urlencoded-encoding-vector (define-values (uri-path-segment-encoding-vector
form-urlencoded-decoding-vector) uri-path-segment-decoding-vector)
(make-codec-tables form-urlencoded-mapping)) (make-codec-tables uri-path-segment-mapping))
;; vector string -> string (define-values (form-urlencoded-encoding-vector
(define (encode table str) form-urlencoded-decoding-vector)
(apply string-append (make-codec-tables form-urlencoded-mapping))
(map (lambda (byte)
(cond
[(< byte ascii-size)
(vector-ref table byte)]
[else (number->hex-string byte)]))
(bytes->list (string->bytes/utf-8 str)))))
;; vector string -> string ;; vector string -> string
(define (decode table str) (define (encode table str)
(define internal-decode (apply string-append
(match-lambda (map (lambda (byte)
[() (list)] (cond
[(#\% (? hex-digit? char1) (? hex-digit? char2) . rest) [(< byte ascii-size)
;; This used to consult the table again, but I think that's (vector-ref table byte)]
;; wrong. For example %2b should produce +, not a space. [else (number->hex-string byte)]))
(cons (string->number (string char1 char2) 16) (bytes->list (string->bytes/utf-8 str)))))
(internal-decode rest))]
[((? ascii-char? char) . rest)
(cons
(vector-ref table (char->integer char))
(internal-decode rest))]
[(char . rest)
(append
(bytes->list (string->bytes/utf-8 (string char)))
(internal-decode rest))]))
(bytes->string/utf-8
(apply bytes (internal-decode (string->list str)))))
(define (ascii-char? c)
(< (char->integer c) ascii-size))
(define (hex-digit? c)
(or (char<=? #\0 c #\9)
(char<=? #\a c #\f)
(char<=? #\A c #\F)))
;; string -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string ;; vector string -> string
(define (uri-decode str) (define (decode table str)
(decode uri-decoding-vector str)) (define internal-decode
(match-lambda
;; string -> string [() (list)]
(define (uri-path-segment-encode str) [(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
(encode uri-path-segment-encoding-vector str)) ;; This used to consult the table again, but I think that's
;; wrong. For example %2b should produce +, not a space.
;; string -> string (cons (string->number (string char1 char2) 16)
(define (uri-path-segment-decode str) (internal-decode rest))]
(decode uri-path-segment-decoding-vector str)) [((? ascii-char? char) . rest)
(cons
(vector-ref table (char->integer char))
(internal-decode rest))]
[(char . rest)
(append
(bytes->list (string->bytes/utf-8 (string char)))
(internal-decode rest))]))
(bytes->string/utf-8
(apply bytes (internal-decode (string->list str)))))
;; string -> string (define (ascii-char? c)
(define (form-urlencoded-encode str) (< (char->integer c) ascii-size))
(encode form-urlencoded-encoding-vector str))
;; string -> string (define (hex-digit? c)
(define (form-urlencoded-decode str) (or (char<=? #\0 c #\9)
(decode form-urlencoded-decoding-vector str)) (char<=? #\a c #\f)
(char<=? #\A c #\F)))
;; listof (cons string string) -> string ;; string -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris (define (uri-encode str)
;; listof (cons symbol string) -> string (encode uri-encoding-vector str))
(define (alist->form-urlencoded args)
(let* ([mode (current-alist-separator-mode)]
[format-one
(lambda (arg)
(let* ([name (car arg)]
[value (cdr arg)])
(string-append (form-urlencoded-encode (symbol->string name))
"="
(form-urlencoded-encode value))))]
[strs (let loop ([args args])
(cond
[(null? args) null]
[(null? (cdr args)) (list (format-one (car args)))]
[else (list* (format-one (car args))
(if (eq? mode 'amp) "&" ";")
(loop (cdr args)))]))])
(apply string-append strs)))
;; string -> listof (cons string string) ;; string -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris (define (uri-decode str)
(define (form-urlencoded->alist str) (decode uri-decoding-vector str))
(define key-regexp #rx"[^=]*")
(define value-regexp (case (current-alist-separator-mode)
[(semi) #rx"[^;]*"]
[(amp) #rx"[^&]*"]
[else #rx"[^&;]*"]))
(define (next-key str start)
(and (< start (string-length str))
(match (regexp-match-positions key-regexp str start)
[((start . end))
(vector (let ([s (form-urlencoded-decode
(substring str start end))])
(string->symbol s))
(add1 end))]
[#f #f])))
(define (next-value str start)
(and (< start (string-length str))
(match (regexp-match-positions value-regexp str start)
[((start . end))
(vector (form-urlencoded-decode (substring str start end))
(add1 end))]
[#f #f])))
(define (next-pair str start)
(match (next-key str start)
[#(key start)
(match (next-value str start)
[#(value start)
(vector (cons key value) start)]
[#f
(vector (cons key "") (string-length str))])]
[#f #f]))
(let loop ([start 0]
[end (string-length str)]
[make-alist (lambda (x) x)])
(if (>= start end)
(make-alist '())
(match (next-pair str start)
[#(pair next-start)
(loop next-start end (lambda (x) (make-alist (cons pair x))))]
[#f (make-alist '())]))))
(define current-alist-separator-mode ;; string -> string
(make-parameter 'amp-or-semi (define (uri-path-segment-encode str)
(lambda (s) (encode uri-path-segment-encoding-vector str))
(unless (memq s '(amp semi amp-or-semi))
(raise-type-error 'current-alist-separator-mode ;; string -> string
"'amp, 'semi, or 'amp-or-semi" (define (uri-path-segment-decode str)
s)) (decode uri-path-segment-decoding-vector str))
s))))
;; string -> string
(define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str))
;; listof (cons string string) -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
;; listof (cons symbol string) -> string
(define (alist->form-urlencoded args)
(let* ([mode (current-alist-separator-mode)]
[format-one
(lambda (arg)
(let* ([name (car arg)]
[value (cdr arg)])
(string-append (form-urlencoded-encode (symbol->string name))
"="
(form-urlencoded-encode value))))]
[strs (let loop ([args args])
(cond
[(null? args) null]
[(null? (cdr args)) (list (format-one (car args)))]
[else (list* (format-one (car args))
(if (eq? mode 'amp) "&" ";")
(loop (cdr args)))]))])
(apply string-append strs)))
;; string -> listof (cons string string)
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
(define (form-urlencoded->alist str)
(define key-regexp #rx"[^=]*")
(define value-regexp (case (current-alist-separator-mode)
[(semi) #rx"[^;]*"]
[(amp) #rx"[^&]*"]
[else #rx"[^&;]*"]))
(define (next-key str start)
(and (< start (string-length str))
(match (regexp-match-positions key-regexp str start)
[((start . end))
(vector (let ([s (form-urlencoded-decode
(substring str start end))])
(string->symbol s))
(add1 end))]
[#f #f])))
(define (next-value str start)
(and (< start (string-length str))
(match (regexp-match-positions value-regexp str start)
[((start . end))
(vector (form-urlencoded-decode (substring str start end))
(add1 end))]
[#f #f])))
(define (next-pair str start)
(match (next-key str start)
[#(key start)
(match (next-value str start)
[#(value start)
(vector (cons key value) start)]
[#f
(vector (cons key "") (string-length str))])]
[#f #f]))
(let loop ([start 0]
[end (string-length str)]
[make-alist (lambda (x) x)])
(if (>= start end)
(make-alist '())
(match (next-pair str start)
[#(pair next-start)
(loop next-start end (lambda (x) (make-alist (cons pair x))))]
[#f (make-alist '())]))))
(define current-alist-separator-mode
(make-parameter 'amp-or-semi
(lambda (s)
(unless (memq s '(amp semi amp-or-semi))
(raise-type-error 'current-alist-separator-mode
"'amp, 'semi, or 'amp-or-semi"
s))
s))))
;;; uri-codec-unit.ss ends here ;;; uri-codec-unit.ss ends here

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

@ -1,8 +1,6 @@
(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^)
(define-values/invoke-unit/infer uri-codec@)) (define-values/invoke-unit/infer 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))))]))
))

12
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"
@ -10,7 +10,7 @@
(define-compound-unit/infer url+tcp@ (define-compound-unit/infer url+tcp@
(import) (export url^) (import) (export url^)
(link tcp@ url@)) (link tcp@ url@))
(define-values/invoke-unit/infer url+tcp@) (define-values/invoke-unit/infer url+tcp@)
(provide (provide
@ -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